From 260e7f2ed9a43c6ecf5a556d77817f39ed2893ab Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 21 Dec 2001 15:07:26 +0000 Subject: [PATCH] [project @ 2001-12-21 15:07:20 by simonmar] Merge up to the ghc/lib/std on the HEAD (tagged as new-libraries-last-merged). --- Control/Concurrent.hs | 5 +- Control/Exception.hs | 4 +- Control/Monad/ST.hs | 4 +- Control/Monad/ST/Lazy.hs | 5 +- Data/Bits.hs | 17 +- Data/Complex.hs | 8 +- Data/Dynamic.hs | 4 +- Data/IORef.hs | 4 +- Data/Ix.hs | 4 +- Data/List.hs | 24 +- Data/Tuple.hs | 24 +- Debug/QuickCheck/Utils.hs | 6 +- Foreign/C/Error.hs | 306 +++++++++++------ Foreign/Marshal/Alloc.hs | 3 +- GHC/Arr.lhs | 76 +++-- GHC/Base.lhs | 92 +++-- GHC/Conc.lhs | 17 +- GHC/Enum.lhs | 20 +- GHC/Float.lhs | 57 +++- GHC/{Handle.hsc => Handle.hs} | 250 +++++++------- GHC/{IO.hsc => IO.hs} | 98 +++--- GHC/IOBase.lhs | 52 +-- GHC/Int.lhs | 373 +++++++++++++++------ GHC/List.lhs | 33 +- GHC/Num.lhs | 25 +- GHC/Posix.hsc | 24 +- GHC/{Prim.hi-boot => Prim.hi-boot.pp} | 75 +++-- GHC/Ptr.lhs | 16 +- GHC/Read.lhs | 25 +- GHC/Real.lhs | 5 +- GHC/ST.lhs | 6 +- GHC/STRef.lhs | 1 - GHC/Show.lhs | 6 +- GHC/Storable.lhs | 60 ++-- GHC/Weak.lhs | 3 +- GHC/Word.lhs | 338 +++++++++++++------ Makefile | 33 +- System/CPUTime.hsc | 12 +- System/Environment.hs | 31 +- System/Mem/StableName.hs | 5 +- System/Random.hs | 12 +- System/Time.hsc | 12 +- cbits/PrelIOUtils.c | 9 + cbits/dirUtils.c | 75 +++++ cbits/errno.c | 596 ++++++++++++++++++++++++++++++++- cbits/ilxstubs.c | 10 +- cbits/inputReady.c | 34 +- cbits/longlong.c | 42 ++- cbits/system.c | 6 +- cbits/writeError.c | 6 +- doc/libraries.sgml | 46 ++- include/CTypes.h | 168 +--------- include/HsCore.h | 156 +++++++-- include/PackedString.h | 14 - include/PrelIOUtils.h | 40 +++ include/dirUtils.h | 38 +++ include/errUtils.h | 110 ++++++ 57 files changed, 2527 insertions(+), 998 deletions(-) rename GHC/{Handle.hsc => Handle.hs} (86%) rename GHC/{IO.hsc => IO.hs} (87%) rename GHC/{Prim.hi-boot => Prim.hi-boot.pp} (88%) create mode 100644 cbits/PrelIOUtils.c create mode 100644 cbits/dirUtils.c delete mode 100644 include/PackedString.h create mode 100644 include/PrelIOUtils.h create mode 100644 include/dirUtils.h create mode 100644 include/errUtils.h diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs index 1409b75..db570bf 100644 --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : non-portable -- --- $Id: Concurrent.hs,v 1.2 2001/08/07 15:25:04 simonmar Exp $ +-- $Id: Concurrent.hs,v 1.3 2001/12/21 15:07:21 simonmar Exp $ -- -- A common interface to a collection of useful concurrency -- abstractions. @@ -53,8 +53,7 @@ import GHC.Conc import GHC.TopHandler ( reportStackOverflow, reportError ) import GHC.IOBase ( IO(..) ) import GHC.IOBase ( unsafeInterleaveIO ) -import GHC.Base ( fork# ) -import GHC.Prim ( Addr#, unsafeCoerce# ) +import GHC.Base #endif #ifdef __HUGS__ diff --git a/Control/Exception.hs b/Control/Exception.hs index abd0861..529d364 100644 --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : non-portable -- --- $Id: Exception.hs,v 1.4 2001/10/18 11:14:17 rrt Exp $ +-- $Id: Exception.hs,v 1.5 2001/12/21 15:07:21 simonmar Exp $ -- -- The External API for exceptions. The functions provided in this -- module allow catching of exceptions in the IO monad. @@ -76,7 +76,7 @@ module Control.Exception ( #ifdef __GLASGOW_HASKELL__ import Prelude hiding (catch) -import GHC.Prim ( assert ) +import GHC.Base ( assert ) import GHC.Exception hiding (try, catch, bracket, bracket_) import GHC.Conc ( throwTo, ThreadId ) import GHC.IOBase ( IO(..) ) diff --git a/Control/Monad/ST.hs b/Control/Monad/ST.hs index 5f47360..dd7829c 100644 --- a/Control/Monad/ST.hs +++ b/Control/Monad/ST.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : non-portable (requires universal quantification for runST) -- --- $Id: ST.hs,v 1.4 2001/07/31 13:31:44 simonmar Exp $ +-- $Id: ST.hs,v 1.5 2001/12/21 15:07:21 simonmar Exp $ -- -- The State Transformer Monad, ST -- @@ -34,7 +34,7 @@ import Data.Dynamic #ifdef __GLASGOW_HASKELL__ import GHC.ST -import GHC.Prim ( unsafeCoerce#, RealWorld ) +import GHC.Base ( unsafeCoerce#, RealWorld ) import GHC.IOBase ( IO(..), stToIO ) -- This relies on IO and ST having the same representation modulo the diff --git a/Control/Monad/ST/Lazy.hs b/Control/Monad/ST/Lazy.hs index 5144dcc..5d3c557 100644 --- a/Control/Monad/ST/Lazy.hs +++ b/Control/Monad/ST/Lazy.hs @@ -8,7 +8,7 @@ -- Stability : provisional -- Portability : non-portable (requires universal quantification for runST) -- --- $Id: Lazy.hs,v 1.2 2001/07/03 11:37:49 simonmar Exp $ +-- $Id: Lazy.hs,v 1.3 2001/12/21 15:07:21 simonmar Exp $ -- -- This module presents an identical interface to Control.Monad.ST, -- but the underlying implementation of the state thread is lazy. @@ -47,10 +47,9 @@ import Data.Array import qualified Control.Monad.ST as ST import qualified GHC.Arr as STArray import qualified GHC.ST -import GHC.Base ( ($), ()(..) ) +import GHC.Base import Control.Monad import Data.Ix -import GHC.Prim #endif #ifdef __HUGS__ diff --git a/Data/Bits.hs b/Data/Bits.hs index 9b68618..8303545 100644 --- a/Data/Bits.hs +++ b/Data/Bits.hs @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable -- --- $Id: Bits.hs,v 1.2 2001/07/03 11:37:49 simonmar Exp $ +-- $Id: Bits.hs,v 1.3 2001/12/21 15:07:21 simonmar Exp $ -- -- Bitwise operations. -- @@ -92,20 +92,13 @@ instance Bits Int where | i# >=# 0# = I# (x# `iShiftL#` i#) | otherwise = I# (x# `iShiftRA#` negateInt# i#) (I# x#) `rotate` (I# i#) = -#if WORD_SIZE_IN_BYTES == 4 I# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (32# -# i'#)))) + (x'# `shiftRL#` (wsib -# i'#)))) where x'# = int2Word# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) -#else - I# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (64# -# i'#)))) - where - x'# = int2Word# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) -#endif - bitSize _ = WORD_SIZE_IN_BYTES * 8 + i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) + wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + bitSize _ = WORD_SIZE_IN_BITS isSigned _ = True instance Bits Integer where diff --git a/Data/Complex.hs b/Data/Complex.hs index e132f21..8482e50 100644 --- a/Data/Complex.hs +++ b/Data/Complex.hs @@ -8,7 +8,7 @@ -- Stability : provisional -- Portability : portable -- --- $Id: Complex.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- $Id: Complex.hs,v 1.2 2001/12/21 15:07:21 simonmar Exp $ -- -- Complex numbers. -- @@ -58,24 +58,30 @@ realPart, imagPart :: (RealFloat a) => Complex a -> a realPart (x :+ _) = x imagPart (_ :+ y) = y +{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-} conjugate :: (RealFloat a) => Complex a -> Complex a conjugate (x:+y) = x :+ (-y) +{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-} mkPolar :: (RealFloat a) => a -> a -> Complex a mkPolar r theta = r * cos theta :+ r * sin theta +{-# SPECIALISE cis :: Double -> Complex Double #-} cis :: (RealFloat a) => a -> Complex a cis theta = cos theta :+ sin theta +{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-} polar :: (RealFloat a) => Complex a -> (a,a) polar z = (magnitude z, phase z) +{-# SPECIALISE magnitude :: Complex Double -> Double #-} magnitude :: (RealFloat a) => Complex a -> a magnitude (x:+y) = scaleFloat k (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int))) where k = max (exponent x) (exponent y) mk = - k +{-# SPECIALISE phase :: Complex Double -> Double #-} phase :: (RealFloat a) => Complex a -> a phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson phase (x:+y) = atan2 y x diff --git a/Data/Dynamic.hs b/Data/Dynamic.hs index e8643a3..356d084 100644 --- a/Data/Dynamic.hs +++ b/Data/Dynamic.hs @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable -- --- $Id: Dynamic.hs,v 1.3 2001/07/03 14:13:32 simonmar Exp $ +-- $Id: Dynamic.hs,v 1.4 2001/12/21 15:07:21 simonmar Exp $ -- -- The Dynamic interface provides basic support for dynamic types. -- @@ -78,8 +78,6 @@ import GHC.Dynamic #endif #ifdef __GLASGOW_HASKELL__ -import GHC.Prim ( unsafeCoerce# ) - unsafeCoerce :: a -> b unsafeCoerce = unsafeCoerce# #endif diff --git a/Data/IORef.hs b/Data/IORef.hs index dcc0eae..910ea86 100644 --- a/Data/IORef.hs +++ b/Data/IORef.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : portable -- --- $Id: IORef.hs,v 1.2 2001/07/03 11:37:49 simonmar Exp $ +-- $Id: IORef.hs,v 1.3 2001/12/21 15:07:21 simonmar Exp $ -- -- Mutable references in the IO monad. -- @@ -29,7 +29,7 @@ module Data.IORef import Prelude #ifdef __GLASGOW_HASKELL__ -import GHC.Prim ( mkWeak# ) +import GHC.Base ( mkWeak# ) import GHC.STRef import GHC.IOBase #if !defined(__PARALLEL_HASKELL__) diff --git a/Data/Ix.hs b/Data/Ix.hs index 8d4d745..5296e11 100644 --- a/Data/Ix.hs +++ b/Data/Ix.hs @@ -8,7 +8,7 @@ -- Stability : provisional -- Portability : portable -- --- $Id: Ix.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- $Id: Ix.hs,v 1.2 2001/12/21 15:07:21 simonmar Exp $ -- -- Class of index types. -- @@ -20,8 +20,8 @@ module Data.Ix ( range -- :: (Ix a) => (a,a) -> [a] , index -- :: (Ix a) => (a,a) -> a -> Int , inRange -- :: (Ix a) => (a,a) -> a -> Bool + , rangeSize -- :: (Ix a) => (a,a) -> Int ) - , rangeSize -- :: (Ix a) => (a,a) -> Int -- Ix instances: -- -- Ix Char diff --git a/Data/List.hs b/Data/List.hs index ce4c9b3..9082db5 100644 --- a/Data/List.hs +++ b/Data/List.hs @@ -9,7 +9,7 @@ -- Stability : provisional -- Portability : portable -- --- $Id: List.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- $Id: List.hs,v 1.2 2001/12/21 15:07:21 simonmar Exp $ -- -- Operations on lists. -- @@ -317,13 +317,21 @@ insertBy cmp x ys@(y:ys') GT -> y : insertBy cmp x ys' _ -> x : ys -maximumBy :: (a -> a -> a) -> [a] -> a -maximumBy _ [] = error "List.maximumBy: empty list" -maximumBy max xs = foldl1 max xs - -minimumBy :: (a -> a -> a) -> [a] -> a -minimumBy _ [] = error "List.minimumBy: empty list" -minimumBy min xs = foldl1 min xs +maximumBy :: (a -> a -> Ordering) -> [a] -> a +maximumBy _ [] = error "List.maximumBy: empty list" +maximumBy cmp xs = foldl1 max xs + where + max x y = case cmp x y of + GT -> x + _ -> y + +minimumBy :: (a -> a -> Ordering) -> [a] -> a +minimumBy _ [] = error "List.minimumBy: empty list" +minimumBy cmp xs = foldl1 min xs + where + min x y = case cmp x y of + GT -> y + _ -> x genericLength :: (Num i) => [b] -> i genericLength [] = 0 diff --git a/Data/Tuple.hs b/Data/Tuple.hs index f1fc78c..d37642a 100644 --- a/Data/Tuple.hs +++ b/Data/Tuple.hs @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable -- --- $Id: Tuple.hs,v 1.1 2001/07/03 11:38:07 simonmar Exp $ +-- $Id: Tuple.hs,v 1.2 2001/12/21 15:07:22 simonmar Exp $ -- -- The tuple data types, and associated functions. -- @@ -30,20 +30,20 @@ import GHC.Base default () -- Double isn't available yet #endif -data (,) a b = (,) a b deriving (Eq, Ord) +data (,) a b = (,) a b deriving (Eq, Ord) data (,,) a b c = (,,) a b c deriving (Eq, Ord) data (,,,) a b c d = (,,,) a b c d deriving (Eq, Ord) data (,,,,) a b c d e = (,,,,) a b c d e deriving (Eq, Ord) -data (,,,,,) a b c d e f = (,,,,,) a b c d e f -data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g -data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h -data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i -data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j -data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k -data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l -data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m -data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n -data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o +data (,,,,,) a b c d e f = (,,,,,) a b c d e f deriving (Eq, Ord) +data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g deriving (Eq, Ord) +data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h deriving (Eq, Ord) +data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i deriving (Eq, Ord) +data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j deriving (Eq, Ord) +data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k deriving (Eq, Ord) +data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l deriving (Eq, Ord) +data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m deriving (Eq, Ord) +data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n deriving (Eq, Ord) +data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o deriving (Eq, Ord) data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q diff --git a/Debug/QuickCheck/Utils.hs b/Debug/QuickCheck/Utils.hs index f6ad91f..a8c2df5 100644 --- a/Debug/QuickCheck/Utils.hs +++ b/Debug/QuickCheck/Utils.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- Module : Debug.QuickCheck.Poly +-- Module : Debug.QuickCheck.Utils -- Copyright : (c) Andy Gill 2001 -- License : BSD-style (see the file libraries/core/LICENSE) -- @@ -8,13 +8,13 @@ -- Stability : experimental -- Portability : portable -- --- $Id: Utils.hs,v 1.1 2001/08/17 12:48:38 simonmar Exp $ +-- $Id: Utils.hs,v 1.2 2001/12/21 15:07:22 simonmar Exp $ -- -- These are some general purpose utilities for use with QuickCheck. -- ----------------------------------------------------------------------------- -module Debug.QuickCheckUtils +module Debug.QuickCheck.Utils ( isAssociativeBy , isAssociative , isCommutableBy diff --git a/Foreign/C/Error.hs b/Foreign/C/Error.hs index 71a05ac..b0d3a91 100644 --- a/Foreign/C/Error.hs +++ b/Foreign/C/Error.hs @@ -9,7 +9,7 @@ -- Stability : provisional -- Portability : portable -- --- $Id: Error.hs,v 1.3 2001/07/31 12:59:30 simonmar Exp $ +-- $Id: Error.hs,v 1.4 2001/12/21 15:07:22 simonmar Exp $ -- -- C-specific Marshalling support: Handling of C "errno" error codes -- @@ -120,6 +120,7 @@ import System.IO ( IOError, Handle, ioError ) -- import of C function that gives address of errno -- This function exists because errno is a variable on some systems, but on -- Windows it is a macro for a function... +-- [yes, global variables and thread safety don't really go hand-in-hand. -- sof] foreign import "ghcErrno" unsafe _errno :: Ptr CInt -- Haskell representation for "errno" values @@ -148,108 +149,108 @@ eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV :: Errno -- --- the CCONST_XXX identifiers are cpp symbols whose value is computed by +-- the cCONST_XXX identifiers are cpp symbols whose value is computed by -- configure -- eOK = Errno 0 -e2BIG = Errno (CCONST_E2BIG) -eACCES = Errno (CCONST_EACCES) -eADDRINUSE = Errno (CCONST_EADDRINUSE) -eADDRNOTAVAIL = Errno (CCONST_EADDRNOTAVAIL) -eADV = Errno (CCONST_EADV) -eAFNOSUPPORT = Errno (CCONST_EAFNOSUPPORT) -eAGAIN = Errno (CCONST_EAGAIN) -eALREADY = Errno (CCONST_EALREADY) -eBADF = Errno (CCONST_EBADF) -eBADMSG = Errno (CCONST_EBADMSG) -eBADRPC = Errno (CCONST_EBADRPC) -eBUSY = Errno (CCONST_EBUSY) -eCHILD = Errno (CCONST_ECHILD) -eCOMM = Errno (CCONST_ECOMM) -eCONNABORTED = Errno (CCONST_ECONNABORTED) -eCONNREFUSED = Errno (CCONST_ECONNREFUSED) -eCONNRESET = Errno (CCONST_ECONNRESET) -eDEADLK = Errno (CCONST_EDEADLK) -eDESTADDRREQ = Errno (CCONST_EDESTADDRREQ) -eDIRTY = Errno (CCONST_EDIRTY) -eDOM = Errno (CCONST_EDOM) -eDQUOT = Errno (CCONST_EDQUOT) -eEXIST = Errno (CCONST_EEXIST) -eFAULT = Errno (CCONST_EFAULT) -eFBIG = Errno (CCONST_EFBIG) -eFTYPE = Errno (CCONST_EFTYPE) -eHOSTDOWN = Errno (CCONST_EHOSTDOWN) -eHOSTUNREACH = Errno (CCONST_EHOSTUNREACH) -eIDRM = Errno (CCONST_EIDRM) -eILSEQ = Errno (CCONST_EILSEQ) -eINPROGRESS = Errno (CCONST_EINPROGRESS) -eINTR = Errno (CCONST_EINTR) -eINVAL = Errno (CCONST_EINVAL) -eIO = Errno (CCONST_EIO) -eISCONN = Errno (CCONST_EISCONN) -eISDIR = Errno (CCONST_EISDIR) -eLOOP = Errno (CCONST_ELOOP) -eMFILE = Errno (CCONST_EMFILE) -eMLINK = Errno (CCONST_EMLINK) -eMSGSIZE = Errno (CCONST_EMSGSIZE) -eMULTIHOP = Errno (CCONST_EMULTIHOP) -eNAMETOOLONG = Errno (CCONST_ENAMETOOLONG) -eNETDOWN = Errno (CCONST_ENETDOWN) -eNETRESET = Errno (CCONST_ENETRESET) -eNETUNREACH = Errno (CCONST_ENETUNREACH) -eNFILE = Errno (CCONST_ENFILE) -eNOBUFS = Errno (CCONST_ENOBUFS) -eNODATA = Errno (CCONST_ENODATA) -eNODEV = Errno (CCONST_ENODEV) -eNOENT = Errno (CCONST_ENOENT) -eNOEXEC = Errno (CCONST_ENOEXEC) -eNOLCK = Errno (CCONST_ENOLCK) -eNOLINK = Errno (CCONST_ENOLINK) -eNOMEM = Errno (CCONST_ENOMEM) -eNOMSG = Errno (CCONST_ENOMSG) -eNONET = Errno (CCONST_ENONET) -eNOPROTOOPT = Errno (CCONST_ENOPROTOOPT) -eNOSPC = Errno (CCONST_ENOSPC) -eNOSR = Errno (CCONST_ENOSR) -eNOSTR = Errno (CCONST_ENOSTR) -eNOSYS = Errno (CCONST_ENOSYS) -eNOTBLK = Errno (CCONST_ENOTBLK) -eNOTCONN = Errno (CCONST_ENOTCONN) -eNOTDIR = Errno (CCONST_ENOTDIR) -eNOTEMPTY = Errno (CCONST_ENOTEMPTY) -eNOTSOCK = Errno (CCONST_ENOTSOCK) -eNOTTY = Errno (CCONST_ENOTTY) -eNXIO = Errno (CCONST_ENXIO) -eOPNOTSUPP = Errno (CCONST_EOPNOTSUPP) -ePERM = Errno (CCONST_EPERM) -ePFNOSUPPORT = Errno (CCONST_EPFNOSUPPORT) -ePIPE = Errno (CCONST_EPIPE) -ePROCLIM = Errno (CCONST_EPROCLIM) -ePROCUNAVAIL = Errno (CCONST_EPROCUNAVAIL) -ePROGMISMATCH = Errno (CCONST_EPROGMISMATCH) -ePROGUNAVAIL = Errno (CCONST_EPROGUNAVAIL) -ePROTO = Errno (CCONST_EPROTO) -ePROTONOSUPPORT = Errno (CCONST_EPROTONOSUPPORT) -ePROTOTYPE = Errno (CCONST_EPROTOTYPE) -eRANGE = Errno (CCONST_ERANGE) -eREMCHG = Errno (CCONST_EREMCHG) -eREMOTE = Errno (CCONST_EREMOTE) -eROFS = Errno (CCONST_EROFS) -eRPCMISMATCH = Errno (CCONST_ERPCMISMATCH) -eRREMOTE = Errno (CCONST_ERREMOTE) -eSHUTDOWN = Errno (CCONST_ESHUTDOWN) -eSOCKTNOSUPPORT = Errno (CCONST_ESOCKTNOSUPPORT) -eSPIPE = Errno (CCONST_ESPIPE) -eSRCH = Errno (CCONST_ESRCH) -eSRMNT = Errno (CCONST_ESRMNT) -eSTALE = Errno (CCONST_ESTALE) -eTIME = Errno (CCONST_ETIME) -eTIMEDOUT = Errno (CCONST_ETIMEDOUT) -eTOOMANYREFS = Errno (CCONST_ETOOMANYREFS) -eTXTBSY = Errno (CCONST_ETXTBSY) -eUSERS = Errno (CCONST_EUSERS) -eWOULDBLOCK = Errno (CCONST_EWOULDBLOCK) -eXDEV = Errno (CCONST_EXDEV) +e2BIG = Errno (cCONST_E2BIG) +eACCES = Errno (cCONST_EACCES) +eADDRINUSE = Errno (cCONST_EADDRINUSE) +eADDRNOTAVAIL = Errno (cCONST_EADDRNOTAVAIL) +eADV = Errno (cCONST_EADV) +eAFNOSUPPORT = Errno (cCONST_EAFNOSUPPORT) +eAGAIN = Errno (cCONST_EAGAIN) +eALREADY = Errno (cCONST_EALREADY) +eBADF = Errno (cCONST_EBADF) +eBADMSG = Errno (cCONST_EBADMSG) +eBADRPC = Errno (cCONST_EBADRPC) +eBUSY = Errno (cCONST_EBUSY) +eCHILD = Errno (cCONST_ECHILD) +eCOMM = Errno (cCONST_ECOMM) +eCONNABORTED = Errno (cCONST_ECONNABORTED) +eCONNREFUSED = Errno (cCONST_ECONNREFUSED) +eCONNRESET = Errno (cCONST_ECONNRESET) +eDEADLK = Errno (cCONST_EDEADLK) +eDESTADDRREQ = Errno (cCONST_EDESTADDRREQ) +eDIRTY = Errno (cCONST_EDIRTY) +eDOM = Errno (cCONST_EDOM) +eDQUOT = Errno (cCONST_EDQUOT) +eEXIST = Errno (cCONST_EEXIST) +eFAULT = Errno (cCONST_EFAULT) +eFBIG = Errno (cCONST_EFBIG) +eFTYPE = Errno (cCONST_EFTYPE) +eHOSTDOWN = Errno (cCONST_EHOSTDOWN) +eHOSTUNREACH = Errno (cCONST_EHOSTUNREACH) +eIDRM = Errno (cCONST_EIDRM) +eILSEQ = Errno (cCONST_EILSEQ) +eINPROGRESS = Errno (cCONST_EINPROGRESS) +eINTR = Errno (cCONST_EINTR) +eINVAL = Errno (cCONST_EINVAL) +eIO = Errno (cCONST_EIO) +eISCONN = Errno (cCONST_EISCONN) +eISDIR = Errno (cCONST_EISDIR) +eLOOP = Errno (cCONST_ELOOP) +eMFILE = Errno (cCONST_EMFILE) +eMLINK = Errno (cCONST_EMLINK) +eMSGSIZE = Errno (cCONST_EMSGSIZE) +eMULTIHOP = Errno (cCONST_EMULTIHOP) +eNAMETOOLONG = Errno (cCONST_ENAMETOOLONG) +eNETDOWN = Errno (cCONST_ENETDOWN) +eNETRESET = Errno (cCONST_ENETRESET) +eNETUNREACH = Errno (cCONST_ENETUNREACH) +eNFILE = Errno (cCONST_ENFILE) +eNOBUFS = Errno (cCONST_ENOBUFS) +eNODATA = Errno (cCONST_ENODATA) +eNODEV = Errno (cCONST_ENODEV) +eNOENT = Errno (cCONST_ENOENT) +eNOEXEC = Errno (cCONST_ENOEXEC) +eNOLCK = Errno (cCONST_ENOLCK) +eNOLINK = Errno (cCONST_ENOLINK) +eNOMEM = Errno (cCONST_ENOMEM) +eNOMSG = Errno (cCONST_ENOMSG) +eNONET = Errno (cCONST_ENONET) +eNOPROTOOPT = Errno (cCONST_ENOPROTOOPT) +eNOSPC = Errno (cCONST_ENOSPC) +eNOSR = Errno (cCONST_ENOSR) +eNOSTR = Errno (cCONST_ENOSTR) +eNOSYS = Errno (cCONST_ENOSYS) +eNOTBLK = Errno (cCONST_ENOTBLK) +eNOTCONN = Errno (cCONST_ENOTCONN) +eNOTDIR = Errno (cCONST_ENOTDIR) +eNOTEMPTY = Errno (cCONST_ENOTEMPTY) +eNOTSOCK = Errno (cCONST_ENOTSOCK) +eNOTTY = Errno (cCONST_ENOTTY) +eNXIO = Errno (cCONST_ENXIO) +eOPNOTSUPP = Errno (cCONST_EOPNOTSUPP) +ePERM = Errno (cCONST_EPERM) +ePFNOSUPPORT = Errno (cCONST_EPFNOSUPPORT) +ePIPE = Errno (cCONST_EPIPE) +ePROCLIM = Errno (cCONST_EPROCLIM) +ePROCUNAVAIL = Errno (cCONST_EPROCUNAVAIL) +ePROGMISMATCH = Errno (cCONST_EPROGMISMATCH) +ePROGUNAVAIL = Errno (cCONST_EPROGUNAVAIL) +ePROTO = Errno (cCONST_EPROTO) +ePROTONOSUPPORT = Errno (cCONST_EPROTONOSUPPORT) +ePROTOTYPE = Errno (cCONST_EPROTOTYPE) +eRANGE = Errno (cCONST_ERANGE) +eREMCHG = Errno (cCONST_EREMCHG) +eREMOTE = Errno (cCONST_EREMOTE) +eROFS = Errno (cCONST_EROFS) +eRPCMISMATCH = Errno (cCONST_ERPCMISMATCH) +eRREMOTE = Errno (cCONST_ERREMOTE) +eSHUTDOWN = Errno (cCONST_ESHUTDOWN) +eSOCKTNOSUPPORT = Errno (cCONST_ESOCKTNOSUPPORT) +eSPIPE = Errno (cCONST_ESPIPE) +eSRCH = Errno (cCONST_ESRCH) +eSRMNT = Errno (cCONST_ESRMNT) +eSTALE = Errno (cCONST_ESTALE) +eTIME = Errno (cCONST_ETIME) +eTIMEDOUT = Errno (cCONST_ETIMEDOUT) +eTOOMANYREFS = Errno (cCONST_ETOOMANYREFS) +eTXTBSY = Errno (cCONST_ETXTBSY) +eUSERS = Errno (cCONST_EUSERS) +eWOULDBLOCK = Errno (cCONST_EWOULDBLOCK) +eXDEV = Errno (cCONST_EXDEV) -- checks whether the given errno value is supported on the current -- architecture @@ -457,7 +458,7 @@ errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do | errno == eNFILE = ResourceExhausted | errno == eNOBUFS = ResourceExhausted | errno == eNODATA = NoSuchThing - | errno == eNODEV = NoSuchThing + | errno == eNODEV = UnsupportedOperation | errno == eNOENT = NoSuchThing | errno == eNOEXEC = InvalidArgument | errno == eNOLCK = ResourceExhausted @@ -513,3 +514,106 @@ errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do #endif foreign import unsafe strerror :: Errno -> IO (Ptr CChar) + + +-- Dreadfully tedious callouts to wrappers which define the +-- actual values for the error codes. +foreign import ccall "prel_error_E2BIG" unsafe cCONST_E2BIG :: CInt +foreign import ccall "prel_error_EACCES" unsafe cCONST_EACCES :: CInt +foreign import ccall "prel_error_EADDRINUSE" unsafe cCONST_EADDRINUSE :: CInt +foreign import ccall "prel_error_EADDRNOTAVAIL" unsafe cCONST_EADDRNOTAVAIL :: CInt +foreign import ccall "prel_error_EADV" unsafe cCONST_EADV :: CInt +foreign import ccall "prel_error_EAFNOSUPPORT" unsafe cCONST_EAFNOSUPPORT :: CInt +foreign import ccall "prel_error_EAGAIN" unsafe cCONST_EAGAIN :: CInt +foreign import ccall "prel_error_EALREADY" unsafe cCONST_EALREADY :: CInt +foreign import ccall "prel_error_EBADF" unsafe cCONST_EBADF :: CInt +foreign import ccall "prel_error_EBADMSG" unsafe cCONST_EBADMSG :: CInt +foreign import ccall "prel_error_EBADRPC" unsafe cCONST_EBADRPC :: CInt +foreign import ccall "prel_error_EBUSY" unsafe cCONST_EBUSY :: CInt +foreign import ccall "prel_error_ECHILD" unsafe cCONST_ECHILD :: CInt +foreign import ccall "prel_error_ECOMM" unsafe cCONST_ECOMM :: CInt +foreign import ccall "prel_error_ECONNABORTED" unsafe cCONST_ECONNABORTED :: CInt +foreign import ccall "prel_error_ECONNREFUSED" unsafe cCONST_ECONNREFUSED :: CInt +foreign import ccall "prel_error_ECONNRESET" unsafe cCONST_ECONNRESET :: CInt +foreign import ccall "prel_error_EDEADLK" unsafe cCONST_EDEADLK :: CInt +foreign import ccall "prel_error_EDESTADDRREQ" unsafe cCONST_EDESTADDRREQ :: CInt +foreign import ccall "prel_error_EDIRTY" unsafe cCONST_EDIRTY :: CInt +foreign import ccall "prel_error_EDOM" unsafe cCONST_EDOM :: CInt +foreign import ccall "prel_error_EDQUOT" unsafe cCONST_EDQUOT :: CInt +foreign import ccall "prel_error_EEXIST" unsafe cCONST_EEXIST :: CInt +foreign import ccall "prel_error_EFAULT" unsafe cCONST_EFAULT :: CInt +foreign import ccall "prel_error_EFBIG" unsafe cCONST_EFBIG :: CInt +foreign import ccall "prel_error_EFTYPE" unsafe cCONST_EFTYPE :: CInt +foreign import ccall "prel_error_EHOSTDOWN" unsafe cCONST_EHOSTDOWN :: CInt +foreign import ccall "prel_error_EHOSTUNREACH" unsafe cCONST_EHOSTUNREACH :: CInt +foreign import ccall "prel_error_EIDRM" unsafe cCONST_EIDRM :: CInt +foreign import ccall "prel_error_EILSEQ" unsafe cCONST_EILSEQ :: CInt +foreign import ccall "prel_error_EINPROGRESS" unsafe cCONST_EINPROGRESS :: CInt +foreign import ccall "prel_error_EINTR" unsafe cCONST_EINTR :: CInt +foreign import ccall "prel_error_EINVAL" unsafe cCONST_EINVAL :: CInt +foreign import ccall "prel_error_EIO" unsafe cCONST_EIO :: CInt +foreign import ccall "prel_error_EISCONN" unsafe cCONST_EISCONN :: CInt +foreign import ccall "prel_error_EISDIR" unsafe cCONST_EISDIR :: CInt +foreign import ccall "prel_error_ELOOP" unsafe cCONST_ELOOP :: CInt +foreign import ccall "prel_error_EMFILE" unsafe cCONST_EMFILE :: CInt +foreign import ccall "prel_error_EMLINK" unsafe cCONST_EMLINK :: CInt +foreign import ccall "prel_error_EMSGSIZE" unsafe cCONST_EMSGSIZE :: CInt +foreign import ccall "prel_error_EMULTIHOP" unsafe cCONST_EMULTIHOP :: CInt +foreign import ccall "prel_error_ENAMETOOLONG" unsafe cCONST_ENAMETOOLONG :: CInt +foreign import ccall "prel_error_ENETDOWN" unsafe cCONST_ENETDOWN :: CInt +foreign import ccall "prel_error_ENETRESET" unsafe cCONST_ENETRESET :: CInt +foreign import ccall "prel_error_ENETUNREACH" unsafe cCONST_ENETUNREACH :: CInt +foreign import ccall "prel_error_ENFILE" unsafe cCONST_ENFILE :: CInt +foreign import ccall "prel_error_ENOBUFS" unsafe cCONST_ENOBUFS :: CInt +foreign import ccall "prel_error_ENODATA" unsafe cCONST_ENODATA :: CInt +foreign import ccall "prel_error_ENODEV" unsafe cCONST_ENODEV :: CInt +foreign import ccall "prel_error_ENOENT" unsafe cCONST_ENOENT :: CInt +foreign import ccall "prel_error_ENOEXEC" unsafe cCONST_ENOEXEC :: CInt +foreign import ccall "prel_error_ENOLCK" unsafe cCONST_ENOLCK :: CInt +foreign import ccall "prel_error_ENOLINK" unsafe cCONST_ENOLINK :: CInt +foreign import ccall "prel_error_ENOMEM" unsafe cCONST_ENOMEM :: CInt +foreign import ccall "prel_error_ENOMSG" unsafe cCONST_ENOMSG :: CInt +foreign import ccall "prel_error_ENONET" unsafe cCONST_ENONET :: CInt +foreign import ccall "prel_error_ENOPROTOOPT" unsafe cCONST_ENOPROTOOPT :: CInt +foreign import ccall "prel_error_ENOSPC" unsafe cCONST_ENOSPC :: CInt +foreign import ccall "prel_error_ENOSR" unsafe cCONST_ENOSR :: CInt +foreign import ccall "prel_error_ENOSTR" unsafe cCONST_ENOSTR :: CInt +foreign import ccall "prel_error_ENOSYS" unsafe cCONST_ENOSYS :: CInt +foreign import ccall "prel_error_ENOTBLK" unsafe cCONST_ENOTBLK :: CInt +foreign import ccall "prel_error_ENOTCONN" unsafe cCONST_ENOTCONN :: CInt +foreign import ccall "prel_error_ENOTDIR" unsafe cCONST_ENOTDIR :: CInt +foreign import ccall "prel_error_ENOTEMPTY" unsafe cCONST_ENOTEMPTY :: CInt +foreign import ccall "prel_error_ENOTSOCK" unsafe cCONST_ENOTSOCK :: CInt +foreign import ccall "prel_error_ENOTTY" unsafe cCONST_ENOTTY :: CInt +foreign import ccall "prel_error_ENXIO" unsafe cCONST_ENXIO :: CInt +foreign import ccall "prel_error_EOPNOTSUPP" unsafe cCONST_EOPNOTSUPP :: CInt +foreign import ccall "prel_error_EPERM" unsafe cCONST_EPERM :: CInt +foreign import ccall "prel_error_EPFNOSUPPORT" unsafe cCONST_EPFNOSUPPORT :: CInt +foreign import ccall "prel_error_EPIPE" unsafe cCONST_EPIPE :: CInt +foreign import ccall "prel_error_EPROCLIM" unsafe cCONST_EPROCLIM :: CInt +foreign import ccall "prel_error_EPROCUNAVAIL" unsafe cCONST_EPROCUNAVAIL :: CInt +foreign import ccall "prel_error_EPROGMISMATCH" unsafe cCONST_EPROGMISMATCH :: CInt +foreign import ccall "prel_error_EPROGUNAVAIL" unsafe cCONST_EPROGUNAVAIL :: CInt +foreign import ccall "prel_error_EPROTO" unsafe cCONST_EPROTO :: CInt +foreign import ccall "prel_error_EPROTONOSUPPORT" unsafe cCONST_EPROTONOSUPPORT :: CInt +foreign import ccall "prel_error_EPROTOTYPE" unsafe cCONST_EPROTOTYPE :: CInt +foreign import ccall "prel_error_ERANGE" unsafe cCONST_ERANGE :: CInt +foreign import ccall "prel_error_EREMCHG" unsafe cCONST_EREMCHG :: CInt +foreign import ccall "prel_error_EREMOTE" unsafe cCONST_EREMOTE :: CInt +foreign import ccall "prel_error_EROFS" unsafe cCONST_EROFS :: CInt +foreign import ccall "prel_error_ERPCMISMATCH" unsafe cCONST_ERPCMISMATCH :: CInt +foreign import ccall "prel_error_ERREMOTE" unsafe cCONST_ERREMOTE :: CInt +foreign import ccall "prel_error_ESHUTDOWN" unsafe cCONST_ESHUTDOWN :: CInt +foreign import ccall "prel_error_ESOCKTNOSUPPORT" unsafe cCONST_ESOCKTNOSUPPORT :: CInt +foreign import ccall "prel_error_ESPIPE" unsafe cCONST_ESPIPE :: CInt +foreign import ccall "prel_error_ESRCH" unsafe cCONST_ESRCH :: CInt +foreign import ccall "prel_error_ESRMNT" unsafe cCONST_ESRMNT :: CInt +foreign import ccall "prel_error_ESTALE" unsafe cCONST_ESTALE :: CInt +foreign import ccall "prel_error_ETIME" unsafe cCONST_ETIME :: CInt +foreign import ccall "prel_error_ETIMEDOUT" unsafe cCONST_ETIMEDOUT :: CInt +foreign import ccall "prel_error_ETOOMANYREFS" unsafe cCONST_ETOOMANYREFS :: CInt +foreign import ccall "prel_error_ETXTBSY" unsafe cCONST_ETXTBSY :: CInt +foreign import ccall "prel_error_EUSERS" unsafe cCONST_EUSERS :: CInt +foreign import ccall "prel_error_EWOULDBLOCK" unsafe cCONST_EWOULDBLOCK :: CInt +foreign import ccall "prel_error_EXDEV" unsafe cCONST_EXDEV :: CInt + diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs index ce5f1c3..6080d0c 100644 --- a/Foreign/Marshal/Alloc.hs +++ b/Foreign/Marshal/Alloc.hs @@ -9,7 +9,7 @@ -- Stability : provisional -- Portability : portable -- --- $Id: Alloc.hs,v 1.3 2001/08/17 12:50:34 simonmar Exp $ +-- $Id: Alloc.hs,v 1.4 2001/12/21 15:07:22 simonmar Exp $ -- -- Marshalling support: basic routines for memory allocation -- @@ -39,7 +39,6 @@ import GHC.Real import GHC.Ptr import GHC.Err import GHC.Base -import GHC.Prim #endif diff --git a/GHC/Arr.lhs b/GHC/Arr.lhs index 940b603..bc8b809 100644 --- a/GHC/Arr.lhs +++ b/GHC/Arr.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: Arr.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $ +% $Id: Arr.lhs,v 1.2 2001/12/21 15:07:22 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -37,17 +37,38 @@ default () %********************************************************* \begin{code} -class (Ord a) => Ix a where +class (Ord a) => Ix a where range :: (a,a) -> [a] index, unsafeIndex :: (a,a) -> a -> Int inRange :: (a,a) -> a -> Bool + rangeSize :: (a,a) -> Int + unsafeRangeSize :: (a,a) -> Int -- Must specify one of index, unsafeIndex index b i | inRange b i = unsafeIndex b i | otherwise = error "Error in array index" unsafeIndex b i = index b i + + -- As long as you don't override the default rangeSize, + -- you can specify unsafeRangeSize as follows, to speed up + -- some operations: + -- + -- unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + -- + rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 + | otherwise = 0 + unsafeRangeSize b = rangeSize b \end{code} +Note that the following is NOT right + rangeSize (l,h) | l <= h = index b h + 1 + | otherwise = 0 + +Because it might be the case that l= fromEnum l && fromEnum i <= fromEnum u + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + ---------------------------------------------------------------------- instance Ix Ordering where -- as derived {-# INLINE range #-} @@ -136,6 +164,8 @@ instance Ix Ordering where -- as derived inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + ---------------------------------------------------------------------- instance Ix () where {-# INLINE range #-} @@ -147,6 +177,7 @@ instance Ix () where {-# INLINE index #-} index b i = unsafeIndex b i + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 ---------------------------------------------------------------------- instance (Ix a, Ix b) => Ix (a, b) where -- as derived @@ -164,6 +195,8 @@ instance (Ix a, Ix b) => Ix (a, b) where -- as derived inRange ((l1,l2),(u1,u2)) (i1,i2) = inRange (l1,u1) i1 && inRange (l2,u2) i2 + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + -- Default method for index ---------------------------------------------------------------------- @@ -184,6 +217,8 @@ instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where inRange (l1,u1) i1 && inRange (l2,u2) i2 && inRange (l3,u3) i3 + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + -- Default method for index ---------------------------------------------------------------------- @@ -204,6 +239,8 @@ instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where inRange (l1,u1) i1 && inRange (l2,u2) i2 && inRange (l3,u3) i3 && inRange (l4,u4) i4 + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + -- Default method for index instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where @@ -226,40 +263,9 @@ instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where inRange (l3,u3) i3 && inRange (l4,u4) i4 && inRange (l5,u5) i5 - -- Default method for index -\end{code} - + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 -%******************************************************** -%* * -\subsection{Size of @Ix@ interval} -%* * -%******************************************************** - -The @rangeSize@ operator returns the number of elements -in the range for an @Ix@ pair. - -\begin{code} -{-# SPECIALISE unsafeRangeSize :: (Int,Int) -> Int #-} -{-# SPECIALISE unsafeRangeSize :: ((Int,Int),(Int,Int)) -> Int #-} -unsafeRangeSize :: (Ix a) => (a,a) -> Int -unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -{-# SPECIALISE rangeSize :: (Int,Int) -> Int #-} -{-# SPECIALISE rangeSize :: ((Int,Int),(Int,Int)) -> Int #-} -rangeSize :: (Ix a) => (a,a) -> Int -rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 - | otherwise = 0 - --- Note that the following is NOT right --- rangeSize (l,h) | l <= h = index b h + 1 --- | otherwise = 0 --- --- Because it might be the case that l b -> b) -> b -> [a] -> b -- foldr _ z [] = z -- foldr f z (x:xs) = f x (foldr f z xs) -{-# INLINE foldr #-} +{-# INLINE [0] foldr #-} +-- Inline only in the final stage, after the foldr/cons rule has had a chance foldr k z xs = go xs where go [] = z go (y:ys) = y `k` go ys build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a] -{-# INLINE 2 build #-} +{-# INLINE [1] build #-} -- The INLINE is important, even though build is tiny, -- because it prevents [] getting inlined in the version that -- appears in the interface file. If [] *is* inlined, it -- won't match with [] appearing in rules in an importing module. -- - -- The "2" says to inline in phase 2 + -- The "1" says to inline in phase 1 build g = g (:) [] augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a] -{-# INLINE 2 augment #-} +{-# INLINE [1] augment #-} augment g xs = g (:) xs {-# RULES @@ -274,8 +275,16 @@ augment g xs = g (:) xs "foldr/id" foldr (:) [] = \x->x "foldr/app" forall xs ys. foldr (:) ys xs = append xs ys -"foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs) -"foldr/nil" forall k z. foldr k z [] = z +-- The foldr/cons rule looks nice, but it can give disastrously +-- bloated code when commpiling +-- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ] +-- i.e. when there are very very long literal lists +-- So I've disabled it for now. We could have special cases +-- for short lists, I suppose. +-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs) + +"foldr/single" forall k z x. foldr k z [x] = k x z +"foldr/nil" forall k z. foldr k z [] = z "augment/build" forall (g::forall b. (a->b->b) -> b -> b) (h::forall b. (a->b->b) -> b -> b) . @@ -295,6 +304,7 @@ augment g xs = g (:) xs \begin{code} map :: (a -> b) -> [a] -> [b] +{-# NOINLINE [1] map #-} map = mapList -- Note eta expanded @@ -318,6 +328,7 @@ mapList f (x:xs) = f x : mapList f xs ---------------------------------------------- \begin{code} (++) :: [a] -> [a] -> [a] +{-# NOINLINE [1] (++) #-} (++) = append {-# RULES @@ -449,9 +460,14 @@ String equality is used when desugaring pattern-matches against strings. \begin{code} eqString :: String -> String -> Bool -eqString = (==) +eqString [] [] = True +eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2 +eqString cs1 cs2 = False + +{-# RULES "eqString" (==) = eqString #-} \end{code} + %********************************************************* %* * \subsection{Type @Int@} @@ -465,10 +481,15 @@ zeroInt, oneInt, twoInt, maxInt, minInt :: Int zeroInt = I# 0# oneInt = I# 1# twoInt = I# 2# -#if WORD_SIZE_IN_BYTES == 4 + +{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -} +#if WORD_SIZE_IN_BITS == 31 +minInt = I# (-0x40000000#) +maxInt = I# 0x3FFFFFFF# +#elif WORD_SIZE_IN_BITS == 32 minInt = I# (-0x80000000#) maxInt = I# 0x7FFFFFFF# -#else +#else minInt = I# (-0x8000000000000000#) maxInt = I# 0x7FFFFFFFFFFFFFFF# #endif @@ -657,10 +678,37 @@ gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool "x# <=# x#" forall x#. x# <=# x# = True #-} -#if WORD_SIZE_IN_BYTES == 4 +-- Wrappers for the shift operations. The uncheckedShift# family are +-- undefined when the amount being shifted by is greater than the size +-- in bits of Int#, so these wrappers perform a check and return +-- either zero or -1 appropriately. +-- +-- Note that these wrappers still produce undefined results when the +-- second argument (the shift amount) is negative. + +shiftL#, shiftRL# :: Word# -> Int# -> Word# + +a `shiftL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0# + | otherwise = a `uncheckedShiftL#` b + +a `shiftRL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0# + | otherwise = a `uncheckedShiftRL#` b + +iShiftL#, iShiftRA#, iShiftRL# :: Int# -> Int# -> Int# + +a `iShiftL#` b | b >=# WORD_SIZE_IN_BITS# = 0# + | otherwise = a `uncheckedIShiftL#` b + +a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if a <# 0# then (-1#) else 0# + | otherwise = a `uncheckedIShiftRA#` b + +a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0# + | otherwise = a `uncheckedIShiftRL#` b + +#if WORD_SIZE_IN_BITS == 32 {-# RULES -"intToInt32#" forall x#. intToInt32# x# = x# -"wordToWord32#" forall x#. wordToWord32# x# = x# +"narrow32Int#" forall x#. narrow32Int# x# = x# +"narrow32Word#" forall x#. narrow32Word# x# = x# #-} #endif @@ -682,6 +730,7 @@ unpacking the strings of error messages. \begin{code} unpackCString# :: Addr# -> [Char] +{-# NOINLINE [1] unpackCString# #-} unpackCString# a = unpackCStringList# a unpackCStringList# :: Addr# -> [Char] @@ -705,6 +754,9 @@ unpackAppendCString# addr rest ch = indexCharOffAddr# addr nh unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a +{-# NOINLINE [0] unpackFoldrCString# #-} +-- Don't inline till right at the end; +-- usually the unpack-list rule turns it into unpackCStringList unpackFoldrCString# addr f z = unpack 0# where @@ -722,18 +774,18 @@ unpackCStringUtf8# addr | ch `eqChar#` '\0'# = [] | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#) | ch `leChar#` '\xDF'# = - C# (chr# ((ord# ch -# 0xC0#) `iShiftL#` 6# +# + C# (chr# ((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6# +# (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) : unpack (nh +# 2#) | ch `leChar#` '\xEF'# = - C# (chr# ((ord# ch -# 0xE0#) `iShiftL#` 12# +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 6# +# + C# (chr# ((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12# +# + (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6# +# (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) : unpack (nh +# 3#) | otherwise = - C# (chr# ((ord# ch -# 0xF0#) `iShiftL#` 18# +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 12# +# - (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `iShiftL#` 6# +# + C# (chr# ((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18# +# + (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12# +# + (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6# +# (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) : unpack (nh +# 4#) where diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index b847a85..5a74f32 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: Conc.lhs,v 1.2 2001/07/03 14:13:32 simonmar Exp $ +% $Id: Conc.lhs,v 1.3 2001/12/21 15:07:22 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -19,7 +19,7 @@ module GHC.Conc , killThread -- :: ThreadId -> IO () , throwTo -- :: ThreadId -> Exception -> IO () , par -- :: a -> b -> b - , seq -- :: a -> b -> b + , pseq -- :: a -> b -> b , yield -- :: IO () -- Waiting @@ -48,7 +48,7 @@ import GHC.IOBase ( IO(..), MVar(..) ) import GHC.Base ( Int(..) ) import GHC.Exception ( Exception(..), AsyncException(..) ) -infixr 0 `par`, `seq` +infixr 0 `par`, `pseq` \end{code} %************************************************************************ @@ -81,7 +81,10 @@ yield :: IO () yield = IO $ \s -> case (yield# s) of s1 -> (# s1, () #) --- "seq" is defined a bit weirdly (see below) +-- Nota Bene: 'pseq' used to be 'seq' +-- but 'seq' is now defined in PrelGHC +-- +-- "pseq" is defined a bit weirdly (see below) -- -- The reason for the strange "0# -> parError" case is that -- it fools the compiler into thinking that seq is non-strict in @@ -92,9 +95,9 @@ yield = IO $ \s -> -- Just before converting from Core to STG there's a bit of magic -- that recognises the seq# and eliminates the duff case. -{-# INLINE seq #-} -seq :: a -> b -> b -seq x y = case (seq# x) of { 0# -> seqError; _ -> y } +{-# INLINE pseq #-} +pseq :: a -> b -> b +pseq x y = case (seq# x) of { 0# -> seqError; _ -> y } {-# INLINE par #-} par :: a -> b -> b diff --git a/GHC/Enum.lhs b/GHC/Enum.lhs index 1391b1f..7e5f9d9 100644 --- a/GHC/Enum.lhs +++ b/GHC/Enum.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: Enum.lhs,v 1.5 2001/07/31 13:06:51 simonmar Exp $ +% $Id: Enum.lhs,v 1.6 2001/12/21 15:07:22 simonmar Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -205,11 +205,13 @@ instance Enum Char where {-# INLINE enumFromThenTo #-} enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y) +{-# NOINLINE [1] eftChar #-} +{-# NOINLINE [1] efdChar #-} +{-# NOINLINE [1] efdtChar #-} eftChar = eftCharList efdChar = efdCharList efdtChar = efdtCharList - {-# RULES "eftChar" forall x y. eftChar x y = build (\c n -> eftCharFB c n x y) "efdChar" forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2) @@ -222,7 +224,7 @@ efdtChar = efdtCharList -- We can do better than for Ints because we don't -- have hassles about arithmetic overflow at maxBound -{-# INLINE eftCharFB #-} +{-# INLINE [0] eftCharFB #-} eftCharFB c n x y = go x where go x | x ># y = n @@ -233,6 +235,7 @@ eftCharList x y | x ># y = [] -- For enumFromThenTo we give up on inlining +{-# NOINLINE [0] efdCharFB #-} efdCharFB c n x1 x2 | delta >=# 0# = go_up_char_fb c n x1 delta 0x10FFFF# | otherwise = go_dn_char_fb c n x1 delta 0# @@ -245,6 +248,7 @@ efdCharList x1 x2 where delta = x2 -# x1 +{-# NOINLINE [0] efdtCharFB #-} efdtCharFB c n x1 x2 lim | delta >=# 0# = go_up_char_fb c n x1 delta lim | otherwise = go_dn_char_fb c n x1 delta lim @@ -313,7 +317,8 @@ instance Enum Int where fromEnum x = x {-# INLINE enumFrom #-} - enumFrom (I# x) = case maxInt of I# y -> eftInt x y + enumFrom (I# x) = eftInt x maxInt# + where I# maxInt# = maxInt -- Blarg: technically I guess enumFrom isn't strict! {-# INLINE enumFromTo #-} @@ -325,6 +330,9 @@ instance Enum Int where {-# INLINE enumFromThenTo #-} enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y +{-# NOINLINE [1] eftInt #-} +{-# NOINLINE [1] efdInt #-} +{-# NOINLINE [1] efdtInt #-} eftInt = eftIntList efdInt = efdIntList efdtInt = efdtIntList @@ -340,7 +348,7 @@ efdtInt = efdtIntList #-} -{-# INLINE eftIntFB #-} +{-# INLINE [0] eftIntFB #-} eftIntFB c n x y | x ># y = n | otherwise = go x where @@ -358,6 +366,7 @@ eftIntList x y | x ># y = [] -- For enumFromThenTo we give up on inlining; so we don't worry -- about duplicating occurrences of "c" +{-# NOINLINE [0] efdtIntFB #-} efdtIntFB c n x1 x2 y | delta >=# 0# = if x1 ># y then n else go_up_int_fb c n x1 delta lim | otherwise = if x1 <# y then n else go_dn_int_fb c n x1 delta lim @@ -372,6 +381,7 @@ efdtIntList x1 x2 y delta = x2 -# x1 lim = y -# delta +{-# NOINLINE [0] efdIntFB #-} efdIntFB c n x1 x2 | delta >=# 0# = case maxInt of I# y -> go_up_int_fb c n x1 delta (y -# delta) | otherwise = case minInt of I# y -> go_dn_int_fb c n x1 delta (y -# delta) diff --git a/GHC/Float.lhs b/GHC/Float.lhs index 08fa67c..6bd7df4 100644 --- a/GHC/Float.lhs +++ b/GHC/Float.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: Float.lhs,v 1.2 2001/07/03 14:13:32 simonmar Exp $ +% $Id: Float.lhs,v 1.3 2001/12/21 15:07:22 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -496,13 +496,15 @@ formatRealFloat fmt decs x mk0 ls = case ls of { "" -> "0" ; _ -> ls} in case decs of - Nothing -> - let - f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs - f n s "" = f (n-1) ('0':s) "" - f n s (r:rs) = f (n-1) (r:s) rs - in - f e "" ds + Nothing + | e <= 0 -> "0." ++ replicate (-e) '0' ++ ds + | otherwise -> + let + f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs + in + f e "" ds Just dec -> let dec' = max dec 0 in if e >= 0 then @@ -516,8 +518,8 @@ formatRealFloat fmt decs x (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is) d:ds' = map intToDigit (if ei > 0 then is' else 0:is') in - d : '.' : ds' - + d : (if null ds' then "" else '.':ds') + roundTo :: Int -> Int -> [Int] -> (Int,[Int]) roundTo base d is = @@ -536,13 +538,18 @@ roundTo base d is = (c,ds) = f (n-1) xs i' = c + i --- -- Based on "Printing Floating-Point Numbers Quickly and Accurately" -- by R.G. Burger and R.K. Dybvig in PLDI 96. -- This version uses a much slower logarithm estimator. It should be improved. --- This function returns a list of digits (Ints in [0..base-1]) and an --- exponent. +-- floatToDigits takes a base and a non-negative RealFloat number, +-- and returns a list of digits and an exponent. +-- In particular, if x>=0, and +-- floatToDigits base x = ([d1,d2,...,dn], e) +-- then +-- (a) n >= 1 +-- (b) x = 0.d1d2...dn * (base**e) +-- (c) 0 <= di <= base-1 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) floatToDigits _ 0 = ([0], 0) @@ -761,6 +768,18 @@ minusFloat (F# x) (F# y) = F# (minusFloat# x y) timesFloat (F# x) (F# y) = F# (timesFloat# x y) divideFloat (F# x) (F# y) = F# (divideFloat# x y) +{-# RULES +"plusFloat x 0.0" forall x#. plusFloat# x# 0.0# = x# +"plusFloat 0.0 x" forall x#. plusFloat# 0.0# x# = x# +"minusFloat x 0.0" forall x#. minusFloat# x# 0.0# = x# +"minusFloat x x" forall x#. minusFloat# x# x# = 0.0# +"timesFloat x 0.0" forall x#. timesFloat# x# 0.0# = 0.0# +"timesFloat0.0 x" forall x#. timesFloat# 0.0# x# = 0.0# +"timesFloat x 1.0" forall x#. timesFloat# x# 1.0# = x# +"timesFloat 1.0 x" forall x#. timesFloat# 1.0# x# = x# +"divideFloat x 1.0" forall x#. divideFloat# x# 1.0# = x# + #-} + negateFloat :: Float -> Float negateFloat (F# x) = F# (negateFloat# x) @@ -807,6 +826,18 @@ minusDouble (D# x) (D# y) = D# (x -## y) timesDouble (D# x) (D# y) = D# (x *## y) divideDouble (D# x) (D# y) = D# (x /## y) +{-# RULES +"plusDouble x 0.0" forall x#. (+##) x# 0.0## = x# +"plusDouble 0.0 x" forall x#. (+##) 0.0## x# = x# +"minusDouble x 0.0" forall x#. (-##) x# 0.0## = x# +"minusDouble x x" forall x#. (-##) x# x# = 0.0## +"timesDouble x 0.0" forall x#. (*##) x# 0.0## = 0.0## +"timesDouble 0.0 x" forall x#. (*##) 0.0## x# = 0.0## +"timesDouble x 1.0" forall x#. (*##) x# 1.0## = x# +"timesDouble 1.0 x" forall x#. (*##) 1.0## x# = x# +"divideDouble x 1.0" forall x#. (/##) x# 1.0## = x# + #-} + negateDouble :: Double -> Double negateDouble (D# x) = D# (negateDouble# x) diff --git a/GHC/Handle.hsc b/GHC/Handle.hs similarity index 86% rename from GHC/Handle.hsc rename to GHC/Handle.hs index cf0956a..94b0203 100644 --- a/GHC/Handle.hsc +++ b/GHC/Handle.hs @@ -1,10 +1,10 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-} #undef DEBUG_DUMP #undef DEBUG -- ----------------------------------------------------------------------------- --- $Id: Handle.hsc,v 1.6 2001/09/14 11:25:24 simonmar Exp $ +-- $Id: Handle.hs,v 1.1 2001/12/21 15:07:22 simonmar Exp $ -- -- (c) The University of Glasgow, 1994-2001 -- @@ -40,8 +40,6 @@ module GHC.Handle ( ) where -#include "HsCore.h" - import Control.Monad import Data.Bits import Data.Maybe @@ -77,8 +75,8 @@ import GHC.Conc -- --------------------------------------------------------------------------- -- Are files opened by default in text or binary mode, if the user doesn't -- specify? -dEFAULT_OPEN_IN_BINARY_MODE :: Bool -dEFAULT_OPEN_IN_BINARY_MODE = False + +dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool -- --------------------------------------------------------------------------- -- Creating a new handle @@ -226,7 +224,7 @@ checkReadableHandle act handle_ = let ref = haBuffer handle_ buf <- readIORef ref when (bufferIsWritable buf) $ do - new_buf <- flushWriteBuffer (haFD handle_) buf + new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf writeIORef ref new_buf{ bufState=ReadBuffer } act handle_ _other -> act handle_ @@ -246,9 +244,9 @@ checkSeekableHandle act handle_ = ClosedHandle -> ioe_closedHandle SemiClosedHandle -> ioe_closedHandle AppendHandle -> ioe_notSeekable - _ | haIsBin handle_ -> act handle_ - | otherwise -> ioe_notSeekable_notBin - + _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_ + | otherwise -> ioe_notSeekable_notBin + -- ----------------------------------------------------------------------------- -- Handy IOErrors @@ -272,8 +270,9 @@ ioe_notSeekable = ioException "handle is not seekable" Nothing) ioe_notSeekable_notBin = ioException (IOError Nothing IllegalOperation "" - "seek operations are only allowed on binary-mode handles" Nothing) - + "seek operations on text-mode handles are not allowed on this platform" + Nothing) + ioe_bufsiz :: Int -> IO a ioe_bufsiz n = ioException (IOError Nothing InvalidArgument "hSetBuffering" @@ -285,10 +284,9 @@ ioe_bufsiz n = ioException -- For a duplex handle, we arrange that the read side points to the write side -- (and hence keeps it alive if the read side is alive). This is done by --- having the haType field of the read side be ReadSideHandle with a pointer --- to the write side. The finalizer is then placed on the write side, and --- the handle only gets finalized once, when both sides are no longer --- required. +-- having the haOtherSide field of the read side point to the read side. +-- The finalizer is then placed on the write side, and the handle only gets +-- finalized once, when both sides are no longer required. stdHandleFinalizer :: MVar Handle__ -> IO () stdHandleFinalizer m = do @@ -301,8 +299,12 @@ handleFinalizer m = do flushWriteBufferOnly h_ let fd = fromIntegral (haFD h_) unlockFile fd - -- ToDo: closesocket() for a WINSOCK socket? - when (fd /= -1) (c_close fd >> return ()) + when (fd /= -1) +#ifdef mingw32_TARGET_OS + (closeFd (haIsStream h_) fd >> return ()) +#else + (c_close fd >> return ()) +#endif return () -- --------------------------------------------------------------------------- @@ -345,8 +347,6 @@ readCharFromBuffer slab (I## off) = IO $ \s -> case readCharArray## slab off s of (## s, c ##) -> (## s, (C## c, I## (off +## 1##)) ##) -dEFAULT_BUFFER_SIZE = (#const BUFSIZ) :: Int - getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode) getBuffer fd state = do buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state @@ -371,7 +371,7 @@ flushWriteBufferOnly h_ = do ref = haBuffer h_ buf <- readIORef ref new_buf <- if bufferIsWritable buf - then flushWriteBuffer fd buf + then flushWriteBuffer fd (haIsStream h_) buf else return buf writeIORef ref new_buf @@ -385,7 +385,7 @@ flushBuffer h_ = do flushed_buf <- case bufState buf of ReadBuffer -> flushReadBuffer (haFD h_) buf - WriteBuffer -> flushWriteBuffer (haFD h_) buf + WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf writeIORef ref flushed_buf @@ -403,11 +403,11 @@ flushReadBuffer fd buf puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") # endif throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek (fromIntegral fd) (fromIntegral off) (#const SEEK_CUR)) + (c_lseek (fromIntegral fd) (fromIntegral off) sSEEK_CUR) return buf{ bufWPtr=0, bufRPtr=0 } -flushWriteBuffer :: FD -> Buffer -> IO Buffer -flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do +flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer +flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do let bytes = w - r #ifdef DEBUG_DUMP puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n") @@ -416,24 +416,24 @@ flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do then return (buf{ bufRPtr=0, bufWPtr=0 }) else do res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer" - (write_off (fromIntegral fd) b (fromIntegral r) + (write_off (fromIntegral fd) is_stream b (fromIntegral r) (fromIntegral bytes)) (threadWaitWrite fd) let res' = fromIntegral res if res' < bytes - then flushWriteBuffer fd (buf{ bufRPtr = r + res' }) + then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' }) else return buf{ bufRPtr=0, bufWPtr=0 } -foreign import "write_wrap" unsafe - write_off :: CInt -> RawBuffer -> Int -> CInt -> IO CInt +foreign import "__hscore_PrelHandle_write" unsafe + write_off :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -fillReadBuffer :: FD -> Bool -> Buffer -> IO Buffer -fillReadBuffer fd is_line +fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer +fillReadBuffer fd is_line is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = -- buffer better be empty: assert (r == 0 && w == 0) $ do - fillReadBufferLoop fd is_line buf b w size + fillReadBufferLoop fd is_line is_stream buf b w size -- For a line buffer, we just get the first chunk of data to arrive, -- and don't wait for the whole buffer to be full (but we *do* wait @@ -441,7 +441,7 @@ fillReadBuffer fd is_line -- appears to be what GHC has done for a long time, and I suspect it -- is more useful than line buffering in most cases. -fillReadBufferLoop fd is_line buf b w size = do +fillReadBufferLoop fd is_line is_stream buf b w size = do let bytes = size - w if bytes == 0 -- buffer full? then return buf{ bufRPtr=0, bufWPtr=w } @@ -450,7 +450,7 @@ fillReadBufferLoop fd is_line buf b w size = do puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n") #endif res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer" - (read_off fd b (fromIntegral w) (fromIntegral bytes)) + (read_off fd is_stream b (fromIntegral w) (fromIntegral bytes)) (threadWaitRead fd) let res' = fromIntegral res #ifdef DEBUG_DUMP @@ -461,11 +461,11 @@ fillReadBufferLoop fd is_line buf b w size = do then ioe_EOF else return buf{ bufRPtr=0, bufWPtr=w } else if res' < bytes && not is_line - then fillReadBufferLoop fd is_line buf b (w+res') size + then fillReadBufferLoop fd is_line is_stream buf b (w+res') size else return buf{ bufRPtr=0, bufWPtr=w+res' } -foreign import "read_wrap" unsafe - read_off :: FD -> RawBuffer -> Int -> CInt -> IO CInt +foreign import "__hscore_PrelHandle_read" unsafe + read_off :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -- --------------------------------------------------------------------------- -- Standard Handles @@ -484,16 +484,7 @@ stdin = unsafePerformIO $ do -- ToDo: acquire lock setNonBlockingFD fd_stdin (buf, bmode) <- getBuffer fd_stdin ReadBuffer - spares <- newIORef BufferListNil - newFileHandle stdHandleFinalizer - (Handle__ { haFD = fd_stdin, - haType = ReadHandle, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haBufferMode = bmode, - haFilePath = "", - haBuffer = buf, - haBuffers = spares - }) + mkStdHandle fd_stdin "" ReadHandle buf bmode stdout :: Handle stdout = unsafePerformIO $ do @@ -502,16 +493,7 @@ stdout = unsafePerformIO $ do -- some shells don't recover properly. -- setNonBlockingFD fd_stdout (buf, bmode) <- getBuffer fd_stdout WriteBuffer - spares <- newIORef BufferListNil - newFileHandle stdHandleFinalizer - (Handle__ { haFD = fd_stdout, - haType = WriteHandle, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haBufferMode = bmode, - haFilePath = "", - haBuffer = buf, - haBuffers = spares - }) + mkStdHandle fd_stdout "" WriteHandle buf bmode stderr :: Handle stderr = unsafePerformIO $ do @@ -519,17 +501,8 @@ stderr = unsafePerformIO $ do -- We don't set non-blocking mode on stdout or sterr, because -- some shells don't recover properly. -- setNonBlockingFD fd_stderr - buffer <- mkUnBuffer - spares <- newIORef BufferListNil - newFileHandle stdHandleFinalizer - (Handle__ { haFD = fd_stderr, - haType = WriteHandle, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haBufferMode = NoBuffering, - haFilePath = "", - haBuffer = buffer, - haBuffers = spares - }) + buf <- mkUnBuffer + mkStdHandle fd_stderr "" WriteHandle buf NoBuffering -- --------------------------------------------------------------------------- -- Opening and Closing Files @@ -607,9 +580,7 @@ openFile' filepath ex_mode = | otherwise = False binary_flags -#ifdef HAVE_O_BINARY - | binary = o_BINARY -#endif + | binary = PrelHandle.o_BINARY | otherwise = 0 oflags = oflags1 .|. binary_flags @@ -624,7 +595,7 @@ openFile' filepath ex_mode = throwErrnoIfMinus1Retry "openFile" (c_open f (fromIntegral oflags) 0o666) - openFd fd filepath mode binary truncate + openFd fd Nothing filepath mode binary truncate -- ASSERT: if we just created the file, then openFd won't fail -- (so we don't need to worry about removing the newly created file -- in the event of an error). @@ -640,8 +611,8 @@ append_flags = write_flags .|. o_APPEND -- --------------------------------------------------------------------------- -- openFd -openFd :: FD -> FilePath -> IOMode -> Bool -> Bool -> IO Handle -openFd fd filepath mode binary truncate = do +openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle +openFd fd mb_fd_type filepath mode binary truncate = do -- turn on non-blocking mode setNonBlockingFD fd @@ -654,15 +625,19 @@ openFd fd filepath mode binary truncate = do -- open() won't tell us if it was a directory if we only opened for -- reading, so check again. - fd_type <- fdType fd + fd_type <- + case mb_fd_type of + Just x -> return x + Nothing -> fdType fd + let is_stream = fd_type == Stream case fd_type of Directory -> ioException (IOError Nothing InappropriateType "openFile" "is a directory" Nothing) Stream - | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary - | otherwise -> mkFileHandle fd filepath ha_type binary + | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary + | otherwise -> mkFileHandle fd is_stream filepath ha_type binary -- regular files need to be locked RegularFile -> do @@ -674,7 +649,7 @@ openFd fd filepath mode binary truncate = do -- truncate the file if necessary when truncate (fileTruncate filepath) - mkFileHandle fd filepath ha_type binary + mkFileHandle fd is_stream filepath ha_type binary foreign import "lockFile" unsafe @@ -683,32 +658,52 @@ foreign import "lockFile" unsafe foreign import "unlockFile" unsafe unlockFile :: CInt -> IO CInt -mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle -mkFileHandle fd filepath ha_type binary = do +mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode + -> IO Handle +mkStdHandle fd filepath ha_type buf bmode = do + spares <- newIORef BufferListNil + newFileHandle stdHandleFinalizer + (Handle__ { haFD = fd, + haType = ha_type, + haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, + haIsStream = False, + haBufferMode = bmode, + haFilePath = filepath, + haBuffer = buf, + haBuffers = spares, + haOtherSide = Nothing + }) + +mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle +mkFileHandle fd is_stream filepath ha_type binary = do (buf, bmode) <- getBuffer fd (initBufferState ha_type) spares <- newIORef BufferListNil newFileHandle handleFinalizer (Handle__ { haFD = fd, haType = ha_type, haIsBin = binary, + haIsStream = is_stream, haBufferMode = bmode, haFilePath = filepath, haBuffer = buf, - haBuffers = spares + haBuffers = spares, + haOtherSide = Nothing }) -mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle -mkDuplexHandle fd filepath binary = do +mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle +mkDuplexHandle fd is_stream filepath binary = do (w_buf, w_bmode) <- getBuffer fd WriteBuffer w_spares <- newIORef BufferListNil let w_handle_ = Handle__ { haFD = fd, haType = WriteHandle, haIsBin = binary, + haIsStream = is_stream, haBufferMode = w_bmode, haFilePath = filepath, haBuffer = w_buf, - haBuffers = w_spares + haBuffers = w_spares, + haOtherSide = Nothing } write_side <- newMVar w_handle_ @@ -716,16 +711,18 @@ mkDuplexHandle fd filepath binary = do r_spares <- newIORef BufferListNil let r_handle_ = Handle__ { haFD = fd, - haType = ReadSideHandle write_side, + haType = ReadHandle, haIsBin = binary, + haIsStream = is_stream, haBufferMode = r_bmode, haFilePath = filepath, haBuffer = r_buf, - haBuffers = r_spares + haBuffers = r_spares, + haOtherSide = Just write_side } read_side <- newMVar r_handle_ - addMVarFinalizer write_side (handleFinalizer write_side) + addMVarFinalizer read_side (handleFinalizer read_side) return (DuplexHandle read_side write_side) @@ -744,22 +741,32 @@ initBufferState _ = WriteBuffer hClose :: Handle -> IO () hClose h@(FileHandle m) = hClose' h m -hClose h@(DuplexHandle r w) = do - hClose' h w - withHandle__' "hClose" h r $ \ handle_ -> do - return handle_{ haFD = -1, - haType = ClosedHandle - } +hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r hClose' h m = withHandle__' "hClose" h m $ hClose_help +-- hClose_help is also called by lazyRead (in PrelIO) when EOF is read +-- or an IO error occurs on a lazy stream. The semi-closed Handle is +-- then closed immediately. We have to be careful with DuplexHandles +-- though: we have to leave the closing to the finalizer in that case, +-- because the write side may still be in use. hClose_help handle_ = case haType handle_ of ClosedHandle -> return handle_ _ -> do let fd = fromIntegral (haFD handle_) flushWriteBufferOnly handle_ - throwErrnoIfMinus1Retry_ "hClose" (c_close fd) + + -- close the file descriptor, but not when this is the read side + -- of a duplex handle. + case haOtherSide handle_ of + Nothing -> throwErrnoIfMinus1Retry_ "hClose" +#ifdef mingw32_TARGET_OS + (closeFd (haIsStream handle_) fd) +#else + (c_close fd) +#endif + Just _ -> return () -- free the spare buffers writeIORef (haBuffers handle_) BufferListNil @@ -827,7 +834,7 @@ hLookAhead handle = do -- fill up the read buffer if necessary new_buf <- if bufferEmpty buf - then fillReadBuffer fd is_line buf + then fillReadBuffer fd is_line (haIsStream handle_) buf else return buf writeIORef ref new_buf @@ -916,7 +923,7 @@ hFlush handle = wantWritableHandle "hFlush" handle $ \ handle_ -> do buf <- readIORef (haBuffer handle_) if bufferIsWritable buf && not (bufferEmpty buf) - then do flushed_buf <- flushWriteBuffer (haFD handle_) buf + then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf writeIORef (haBuffer handle_) flushed_buf else return () @@ -929,6 +936,10 @@ data HandlePosn = HandlePosn Handle HandlePosition instance Eq HandlePosn where (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 +instance Show HandlePosn where + showsPrec p (HandlePosn h pos) = + showsPrec p h . showString " at position " . shows pos + -- HandlePosition is the Haskell equivalent of POSIX' off_t. -- We represent it as an Integer on the Haskell side, but -- cheat slightly in that hGetPosn calls upon a C helper @@ -943,7 +954,7 @@ hGetPosn :: Handle -> IO HandlePosn hGetPosn handle = wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do -#if defined(_WIN32) +#if defined(mingw32_TARGET_OS) -- urgh, on Windows we have to worry about \n -> \r\n translation, -- so we can't easily calculate the file position using the -- current buffer size. Just flush instead. @@ -952,7 +963,7 @@ hGetPosn handle = let fd = fromIntegral (haFD handle_) posn <- fromIntegral `liftM` throwErrnoIfMinus1Retry "hGetPosn" - (c_lseek fd 0 (#const SEEK_CUR)) + (c_lseek fd 0 sEEK_CUR) let ref = haBuffer handle_ buf <- readIORef ref @@ -1021,12 +1032,12 @@ hSeek handle mode offset = whence :: CInt whence = case mode of - AbsoluteSeek -> (#const SEEK_SET) - RelativeSeek -> (#const SEEK_CUR) - SeekFromEnd -> (#const SEEK_END) + AbsoluteSeek -> sEEK_SET + RelativeSeek -> sEEK_CUR + SeekFromEnd -> sEEK_END if bufferIsWritable buf - then do new_buf <- flushWriteBuffer fd buf + then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf writeIORef ref new_buf do_seek else do @@ -1109,7 +1120,9 @@ hIsSeekable handle = SemiClosedHandle -> ioe_closedHandle AppendHandle -> return False _ -> do t <- fdType (haFD handle_) - return (t == RegularFile && haIsBin handle_) + return (t == RegularFile + && (haIsBin handle_ + || tEXT_MODE_SEEK_ALLOWED)) -- ----------------------------------------------------------------------------- -- Changing echo status @@ -1149,21 +1162,14 @@ hIsTerminalDevice handle = do -- ----------------------------------------------------------------------------- -- hSetBinaryMode -#ifdef _WIN32 hSetBinaryMode handle bin = withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> - do let flg | bin = (#const O_BINARY) - | otherwise = (#const O_TEXT) - throwErrnoIfMinus1_ "hSetBinaryMode" - (setmode (fromIntegral (haFD handle_)) flg) + do throwErrnoIfMinus1_ "hSetBinaryMode" + (setmode (fromIntegral (haFD handle_)) bin) return handle_{haIsBin=bin} - -foreign import "setmode" setmode :: CInt -> CInt -> IO CInt -#else -hSetBinaryMode handle bin = - withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> - return handle_{haIsBin=bin} -#endif + +foreign import "__hscore_setmode" unsafe + setmode :: CInt -> Bool -> IO CInt -- ----------------------------------------------------------------------------- -- Miscellaneous @@ -1194,3 +1200,17 @@ puts :: String -> IO () puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s)) return () #endif + +-- ----------------------------------------------------------------------------- +-- wrappers to platform-specific constants: + +foreign import ccall "__hscore_supportsTextMode" unsafe + tEXT_MODE_SEEK_ALLOWED :: Bool + +foreign import ccall "__hscore_bufsiz" unsafe dEFAULT_BUFFER_SIZE :: Int +foreign import ccall "__hscore_seek_cur" unsafe sEEK_CUR :: CInt +foreign import ccall "__hscore_seek_set" unsafe sEEK_SET :: CInt +foreign import ccall "__hscore_seek_end" unsafe sEEK_END :: CInt +foreign import ccall "__hscore_o_binary" unsafe o_BINARY :: CInt + + diff --git a/GHC/IO.hsc b/GHC/IO.hs similarity index 87% rename from GHC/IO.hsc rename to GHC/IO.hs index ac1e98d..801e683 100644 --- a/GHC/IO.hsc +++ b/GHC/IO.hs @@ -1,9 +1,9 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-} #undef DEBUG_DUMP -- ----------------------------------------------------------------------------- --- $Id: IO.hsc,v 1.3 2001/09/14 11:25:24 simonmar Exp $ +-- $Id: IO.hs,v 1.1 2001/12/21 15:07:23 simonmar Exp $ -- -- (c) The University of Glasgow, 1992-2001 -- @@ -14,9 +14,15 @@ -- but as it happens they also do everything required by library -- module IO. -module GHC.IO where - -#include "HsCore.h" +module GHC.IO ( + putChar, putStr, putStrLn, print, getChar, getLine, getContents, + interact, readFile, writeFile, appendFile, readLn, readIO, hReady, + hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, + hPutStrLn, hPrint, + commitBuffer', -- hack, see below + hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs + hGetBuf, hPutBuf, slurpFile + ) where import Foreign import Foreign.C @@ -58,11 +64,11 @@ hWaitForInput h msecs = do else do r <- throwErrnoIfMinus1Retry "hReady" - (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs)) + (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_)) return (r /= 0) -foreign import "inputReady" - inputReady :: CInt -> CInt -> IO CInt +foreign import "inputReady" unsafe + inputReady :: CInt -> CInt -> Bool -> IO CInt -- --------------------------------------------------------------------------- -- hGetChar @@ -85,16 +91,16 @@ hGetChar handle = -- buffer is empty. case haBufferMode handle_ of LineBuffering -> do - new_buf <- fillReadBuffer fd True buf + new_buf <- fillReadBuffer fd True (haIsStream handle_) buf hGetcBuffered fd ref new_buf BlockBuffering _ -> do - new_buf <- fillReadBuffer fd False buf + new_buf <- fillReadBuffer fd False (haIsStream handle_) buf hGetcBuffered fd ref new_buf NoBuffering -> do -- make use of the minimal buffer we already have let raw = bufBuf buf r <- throwErrnoIfMinus1RetryMayBlock "hGetChar" - (read_off (fromIntegral fd) raw 0 1) + (read_off (fromIntegral fd) (haIsStream handle_) raw 0 1) (threadWaitRead fd) if r == 0 then ioe_EOF @@ -164,7 +170,7 @@ hGetLineBufferedLoop handle_ ref else writeIORef ref buf{ bufRPtr = off + 1 } return (concat (reverse (xs:xss))) else do - maybe_buf <- maybeFillReadBuffer (haFD handle_) True + maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) buf{ bufWPtr=0, bufRPtr=0 } case maybe_buf of -- Nothing indicates we caught an EOF, and we may have a @@ -177,9 +183,9 @@ hGetLineBufferedLoop handle_ ref hGetLineBufferedLoop handle_ ref new_buf (xs:xss) -maybeFillReadBuffer fd is_line buf +maybeFillReadBuffer fd is_line is_stream buf = catch - (do buf <- fillReadBuffer fd is_line buf + (do buf <- fillReadBuffer fd is_line is_stream buf return (Just buf) ) (\e -> do if isEOFError e @@ -273,9 +279,8 @@ lazyRead' h handle_ = do NoBuffering -> do -- make use of the minimal buffer we already have let raw = bufBuf buf - fd = haFD handle_ r <- throwErrnoIfMinus1RetryMayBlock "lazyRead" - (read_off (fromIntegral fd) raw 0 1) + (read_off (fromIntegral fd) (haIsStream handle_) raw 0 1) (threadWaitRead fd) if r == 0 then do handle_ <- hClose_help handle_ @@ -291,7 +296,7 @@ lazyRead' h handle_ = do -- is_line==True, which tells it to "just read what there is". lazyReadBuffered h handle_ fd ref buf = do catch - (do buf <- fillReadBuffer fd True{-is_line-} buf + (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf lazyReadHaveBuffer h handle_ fd ref buf ) -- all I/O errors are discarded. Additionally, we close the handle. @@ -346,7 +351,7 @@ hPutcBuffered handle_ is_line c = do let new_buf = buf{ bufWPtr = w' } if bufferFull new_buf || is_line && c == '\n' then do - flushed_buf <- flushWriteBuffer (haFD handle_) new_buf + flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf writeIORef ref flushed_buf else do writeIORef ref new_buf @@ -424,13 +429,12 @@ writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s = return () shoveString n (c:cs) = do n' <- writeCharIntoBuffer raw n c - -- we're line-buffered, so flush the buffer if we just got a newline - if (c == '\n') - then do - new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False - writeLines hdl new_buf cs - else do - shoveString n' cs + if (c == '\n') + then do + new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False + writeLines hdl new_buf cs + else + shoveString n' cs in shoveString 0 s @@ -476,13 +480,27 @@ commitBuffer :: Handle -- handle to commit to -> RawBuffer -> Int -- address and size (in bytes) of buffer -> Int -- number of bytes of data in buffer - -> Bool -- flush the handle afterward? + -> Bool -- True <=> flush the handle afterward -> Bool -- release the buffer? -> IO Buffer -commitBuffer hdl raw sz count flush release = do - wantWritableHandle "commitAndReleaseBuffer" hdl $ - \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do +commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do + wantWritableHandle "commitAndReleaseBuffer" hdl $ + commitBuffer' hdl raw sz count flush release + +-- Explicitly lambda-lift this function to subvert GHC's full laziness +-- optimisations, which otherwise tends to float out subexpressions +-- past the \handle, which is really a pessimisation in this case because +-- that lambda is a one-shot lambda. +-- +-- Don't forget to export the function, to stop it being inlined too +-- (this appears to be better than NOINLINE, because the strictness +-- analyser still gets to worker-wrapper it). +-- +-- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 +-- +commitBuffer' hdl raw sz@(I## _) count@(I## _) flush release + handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do #ifdef DEBUG_DUMP puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count @@ -509,7 +527,7 @@ commitBuffer hdl raw sz count flush release = do return (newEmptyBuffer raw WriteBuffer sz) -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd old_buf + else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf let this_buf = Buffer{ bufBuf=raw, bufState=WriteBuffer, @@ -527,7 +545,7 @@ commitBuffer hdl raw sz count flush release = do -- otherwise, we have to flush the new data too, -- and start with a fresh buffer else do - flushWriteBuffer fd this_buf + flushWriteBuffer fd (haIsStream handle_) this_buf writeIORef ref flushed_buf -- if the sizes were different, then allocate -- a new buffer of the correct size. @@ -536,13 +554,15 @@ commitBuffer hdl raw sz count flush release = do else allocateBuffer size WriteBuffer -- release the buffer if necessary - if release && bufSize buf_ret == size - then do + case buf_ret of + Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do + if release && buf_ret_sz == size + then do spare_bufs <- readIORef spare_buf_ref writeIORef spare_buf_ref - (BufferListCons (bufBuf buf_ret) spare_bufs) + (BufferListCons buf_ret_raw spare_bufs) return buf_ret - else + else return buf_ret -- --------------------------------------------------------------------------- @@ -678,13 +698,13 @@ slurpFile fname = do -- --------------------------------------------------------------------------- -- memcpy wrappers -foreign import "memcpy_wrap_src_off" unsafe +foreign import "__hscore_memcpy_src_off" unsafe memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ()) -foreign import "memcpy_wrap_src_off" unsafe +foreign import "__hscore_memcpy_src_off" unsafe memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ()) -foreign import "memcpy_wrap_dst_off" unsafe +foreign import "__hscore_memcpy_dst_off" unsafe memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ()) -foreign import "memcpy_wrap_dst_off" unsafe +foreign import "__hscore_memcpy_dst_off" unsafe memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ()) ----------------------------------------------------------------------------- diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs index 1ff572b..7d94236 100644 --- a/GHC/IOBase.lhs +++ b/GHC/IOBase.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: IOBase.lhs,v 1.4 2001/09/13 15:34:17 simonmar Exp $ +% $Id: IOBase.lhs,v 1.5 2001/12/21 15:07:25 simonmar Exp $ % % (c) The University of Glasgow, 1994-2001 % @@ -9,7 +9,6 @@ \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -#include "config.h" module GHC.IOBase where @@ -151,13 +150,16 @@ type FD = Int -- XXX ToDo: should be CInt data Handle__ = Handle__ { - haFD :: !FD, - haType :: HandleType, - haIsBin :: Bool, - haBufferMode :: BufferMode, - haFilePath :: FilePath, - haBuffer :: !(IORef Buffer), - haBuffers :: !(IORef BufferList) + haFD :: !FD, -- file descriptor + haType :: HandleType, -- type (read/write/append etc.) + haIsBin :: Bool, -- binary mode? + haIsStream :: Bool, -- is this a stream handle? + haBufferMode :: BufferMode, -- buffer contains read/write data? + haFilePath :: FilePath, -- file name, possibly + haBuffer :: !(IORef Buffer), -- the current buffer + haBuffers :: !(IORef BufferList), -- spare buffers + haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a + -- duplex handle. } -- --------------------------------------------------------------------------- @@ -235,11 +237,9 @@ data HandleType | WriteHandle | AppendHandle | ReadWriteHandle - | ReadSideHandle !(MVar Handle__) -- read side of a duplex handle isReadableHandleType ReadHandle = True isReadableHandleType ReadWriteHandle = True -isReadableHandleType (ReadSideHandle _) = True isReadableHandleType _ = False isWritableHandleType AppendHandle = True @@ -326,13 +326,12 @@ instance Show HandleType where WriteHandle -> showString "writable" AppendHandle -> showString "writable (append)" ReadWriteHandle -> showString "read-writable" - ReadSideHandle _ -> showString "read-writable (duplex)" instance Show Handle where - showsPrec p (FileHandle h) = showHandle p h - showsPrec p (DuplexHandle h _) = showHandle p h + showsPrec p (FileHandle h) = showHandle p h False + showsPrec p (DuplexHandle _ h) = showHandle p h True -showHandle p h = +showHandle p h duplex = let -- (Big) SIGH: unfolded defn of takeMVar to avoid -- an (oh-so) unfortunate module loop with GHC.Conc. @@ -341,14 +340,18 @@ showHandle p h = case takeMVar# h# s# of { (# s2# , r #) -> case putMVar# h# r s2# of { s3# -> (# s3#, r #) }}}) + + showType | duplex = showString "duplex (read-write)" + | otherwise = showsPrec p (haType hdl_) in showChar '{' . showHdl (haType hdl_) (showString "loc=" . showString (haFilePath hdl_) . showChar ',' . - showString "type=" . showsPrec p (haType hdl_) . showChar ',' . + showString "type=" . showType . showChar ',' . showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' . showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" ) where + showHdl :: HandleType -> ShowS -> ShowS showHdl ht cont = case ht of @@ -522,11 +525,14 @@ data IOErrorType | TimeExpired | ResourceVanished | Interrupted -#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS) - | ComError Int -- HRESULT -#endif - deriving (Eq) - + | DynIOError Dynamic -- cheap&cheerful extensible IO error type. + +instance Eq IOErrorType where + x == y = + case x of + DynIOError{} -> False -- from a strictness POV, compatible with a derived Eq inst? + _ -> getTag# x ==# getTag# y + instance Show IOErrorType where showsPrec _ e = showString $ @@ -549,9 +555,7 @@ instance Show IOErrorType where UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! UnsupportedOperation -> "unsupported operation" EOF -> "end of file" -#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS) - ComError _ -> "COM error" -#endif + DynIOError{} -> "unknown IO error" userError :: String -> IOError userError str = UserError str diff --git a/GHC/Int.lhs b/GHC/Int.lhs index 54e6a5d..d2bf5c2 100644 --- a/GHC/Int.lhs +++ b/GHC/Int.lhs @@ -39,17 +39,17 @@ instance Show Int8 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Int8 where - (I8# x#) + (I8# y#) = I8# (intToInt8# (x# +# y#)) - (I8# x#) - (I8# y#) = I8# (intToInt8# (x# -# y#)) - (I8# x#) * (I8# y#) = I8# (intToInt8# (x# *# y#)) - negate (I8# x#) = I8# (intToInt8# (negateInt# x#)) + (I8# x#) + (I8# y#) = I8# (narrow8Int# (x# +# y#)) + (I8# x#) - (I8# y#) = I8# (narrow8Int# (x# -# y#)) + (I8# x#) * (I8# y#) = I8# (narrow8Int# (x# *# y#)) + negate (I8# x#) = I8# (narrow8Int# (negateInt# x#)) abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger (S# i#) = I8# (intToInt8# i#) - fromInteger (J# s# d#) = I8# (intToInt8# (integer2Int# s# d#)) + fromInteger (S# i#) = I8# (narrow8Int# i#) + fromInteger (J# s# d#) = I8# (narrow8Int# (integer2Int# s# d#)) instance Real Int8 where toRational x = toInteger x % 1 @@ -71,24 +71,24 @@ instance Enum Int8 where instance Integral Int8 where quot x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (intToInt8# (x# `quotInt#` y#)) + | y /= 0 = I8# (narrow8Int# (x# `quotInt#` y#)) | otherwise = divZeroError "quot{Int8}" x rem x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (intToInt8# (x# `remInt#` y#)) + | y /= 0 = I8# (narrow8Int# (x# `remInt#` y#)) | otherwise = divZeroError "rem{Int8}" x div x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (intToInt8# (x# `divInt#` y#)) + | y /= 0 = I8# (narrow8Int# (x# `divInt#` y#)) | otherwise = divZeroError "div{Int8}" x mod x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (intToInt8# (x# `modInt#` y#)) + | y /= 0 = I8# (narrow8Int# (x# `modInt#` y#)) | otherwise = divZeroError "mod{Int8}" x quotRem x@(I8# x#) y@(I8# y#) - | y /= 0 = (I8# (intToInt8# (x# `quotInt#` y#)), - I8# (intToInt8# (x# `remInt#` y#))) + | y /= 0 = (I8# (narrow8Int# (x# `quotInt#` y#)), + I8# (narrow8Int# (x# `remInt#` y#))) | otherwise = divZeroError "quotRem{Int8}" x divMod x@(I8# x#) y@(I8# y#) - | y /= 0 = (I8# (intToInt8# (x# `divInt#` y#)), - I8# (intToInt8# (x# `modInt#` y#))) + | y /= 0 = (I8# (narrow8Int# (x# `divInt#` y#)), + I8# (narrow8Int# (x# `modInt#` y#))) | otherwise = divZeroError "divMod{Int8}" x toInteger (I8# x#) = S# x# @@ -97,11 +97,10 @@ instance Bounded Int8 where maxBound = 0x7F instance Ix Int8 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Int8" - inRange (m,n) i = m <= i && i <= n + range (m,n) = [m..n] + unsafeIndex b@(m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 instance Read Int8 where readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] @@ -112,20 +111,23 @@ instance Bits Int8 where (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I8# x#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I8# x#) `shift` (I# i#) - | i# >=# 0# = I8# (intToInt8# (x# `iShiftL#` i#)) + | i# >=# 0# = I8# (narrow8Int# (x# `iShiftL#` i#)) | otherwise = I8# (x# `iShiftRA#` negateInt# i#) - (I8# x#) `rotate` (I# i#) = - I8# (intToInt8# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (8# -# i'#))))) + (I8# x#) `rotate` (I# i#) + | i'# ==# 0# + = I8# x# + | otherwise + = I8# (narrow8Int# (word2Int# ((x'# `shiftL#` i'#) `or#` + (x'# `shiftRL#` (8# -# i'#))))) where - x'# = wordToWord8# (int2Word# x#) + x'# = narrow8Word# (int2Word# x#) i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) bitSize _ = 8 isSigned _ = True {-# RULES "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8 -"fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (intToInt8# x#) +"fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrow8Int# x#) "fromIntegral/Int8->a" fromIntegral = \(I8# x#) -> fromIntegral (I# x#) #-} @@ -145,17 +147,17 @@ instance Show Int16 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Int16 where - (I16# x#) + (I16# y#) = I16# (intToInt16# (x# +# y#)) - (I16# x#) - (I16# y#) = I16# (intToInt16# (x# -# y#)) - (I16# x#) * (I16# y#) = I16# (intToInt16# (x# *# y#)) - negate (I16# x#) = I16# (intToInt16# (negateInt# x#)) + (I16# x#) + (I16# y#) = I16# (narrow16Int# (x# +# y#)) + (I16# x#) - (I16# y#) = I16# (narrow16Int# (x# -# y#)) + (I16# x#) * (I16# y#) = I16# (narrow16Int# (x# *# y#)) + negate (I16# x#) = I16# (narrow16Int# (negateInt# x#)) abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger (S# i#) = I16# (intToInt16# i#) - fromInteger (J# s# d#) = I16# (intToInt16# (integer2Int# s# d#)) + fromInteger (S# i#) = I16# (narrow16Int# i#) + fromInteger (J# s# d#) = I16# (narrow16Int# (integer2Int# s# d#)) instance Real Int16 where toRational x = toInteger x % 1 @@ -177,24 +179,24 @@ instance Enum Int16 where instance Integral Int16 where quot x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (intToInt16# (x# `quotInt#` y#)) + | y /= 0 = I16# (narrow16Int# (x# `quotInt#` y#)) | otherwise = divZeroError "quot{Int16}" x rem x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (intToInt16# (x# `remInt#` y#)) + | y /= 0 = I16# (narrow16Int# (x# `remInt#` y#)) | otherwise = divZeroError "rem{Int16}" x div x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (intToInt16# (x# `divInt#` y#)) + | y /= 0 = I16# (narrow16Int# (x# `divInt#` y#)) | otherwise = divZeroError "div{Int16}" x mod x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (intToInt16# (x# `modInt#` y#)) + | y /= 0 = I16# (narrow16Int# (x# `modInt#` y#)) | otherwise = divZeroError "mod{Int16}" x quotRem x@(I16# x#) y@(I16# y#) - | y /= 0 = (I16# (intToInt16# (x# `quotInt#` y#)), - I16# (intToInt16# (x# `remInt#` y#))) + | y /= 0 = (I16# (narrow16Int# (x# `quotInt#` y#)), + I16# (narrow16Int# (x# `remInt#` y#))) | otherwise = divZeroError "quotRem{Int16}" x divMod x@(I16# x#) y@(I16# y#) - | y /= 0 = (I16# (intToInt16# (x# `divInt#` y#)), - I16# (intToInt16# (x# `modInt#` y#))) + | y /= 0 = (I16# (narrow16Int# (x# `divInt#` y#)), + I16# (narrow16Int# (x# `modInt#` y#))) | otherwise = divZeroError "divMod{Int16}" x toInteger (I16# x#) = S# x# @@ -203,11 +205,10 @@ instance Bounded Int16 where maxBound = 0x7FFF instance Ix Int16 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Int16" - inRange (m,n) i = m <= i && i <= n + range (m,n) = [m..n] + unsafeIndex b@(m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 instance Read Int16 where readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] @@ -218,13 +219,16 @@ instance Bits Int16 where (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I16# x#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I16# x#) `shift` (I# i#) - | i# >=# 0# = I16# (intToInt16# (x# `iShiftL#` i#)) + | i# >=# 0# = I16# (narrow16Int# (x# `iShiftL#` i#)) | otherwise = I16# (x# `iShiftRA#` negateInt# i#) - (I16# x#) `rotate` (I# i#) = - I16# (intToInt16# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (16# -# i'#))))) + (I16# x#) `rotate` (I# i#) + | i'# ==# 0# + = I16# x# + | otherwise + = I16# (narrow16Int# (word2Int# ((x'# `shiftL#` i'#) `or#` + (x'# `shiftRL#` (16# -# i'#))))) where - x'# = wordToWord16# (int2Word# x#) + x'# = narrow16Word# (int2Word# x#) i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) bitSize _ = 16 isSigned _ = True @@ -233,7 +237,7 @@ instance Bits Int16 where "fromIntegral/Word8->Int16" fromIntegral = \(W8# x#) -> I16# (word2Int# x#) "fromIntegral/Int8->Int16" fromIntegral = \(I8# x#) -> I16# x# "fromIntegral/Int16->Int16" fromIntegral = id :: Int16 -> Int16 -"fromIntegral/a->Int16" fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (intToInt16# x#) +"fromIntegral/a->Int16" fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (narrow16Int# x#) "fromIntegral/Int16->a" fromIntegral = \(I16# x#) -> fromIntegral (I# x#) #-} @@ -241,35 +245,176 @@ instance Bits Int16 where -- type Int32 ------------------------------------------------------------------------ +#if WORD_SIZE_IN_BITS < 32 + +data Int32 = I32# Int32# + +instance Eq Int32 where + (I32# x#) == (I32# y#) = x# `eqInt32#` y# + (I32# x#) /= (I32# y#) = x# `neInt32#` y# + +instance Ord Int32 where + (I32# x#) < (I32# y#) = x# `ltInt32#` y# + (I32# x#) <= (I32# y#) = x# `leInt32#` y# + (I32# x#) > (I32# y#) = x# `gtInt32#` y# + (I32# x#) >= (I32# y#) = x# `geInt32#` y# + +instance Show Int32 where + showsPrec p x = showsPrec p (toInteger x) + +instance Num Int32 where + (I32# x#) + (I32# y#) = I32# (x# `plusInt32#` y#) + (I32# x#) - (I32# y#) = I32# (x# `minusInt32#` y#) + (I32# x#) * (I32# y#) = I32# (x# `timesInt32#` y#) + negate (I32# x#) = I32# (negateInt32# x#) + abs x | x >= 0 = x + | otherwise = negate x + signum x | x > 0 = 1 + signum 0 = 0 + signum _ = -1 + fromInteger (S# i#) = I32# (intToInt32# i#) + fromInteger (J# s# d#) = I32# (integerToInt32# s# d#) + +instance Enum Int32 where + succ x + | x /= maxBound = x + 1 + | otherwise = succError "Int32" + pred x + | x /= minBound = x - 1 + | otherwise = predError "Int32" + toEnum (I# i#) = I32# (intToInt32# i#) + fromEnum x@(I32# x#) + | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) + = I# (int32ToInt# x#) + | otherwise = fromEnumError "Int32" x + enumFrom = integralEnumFrom + enumFromThen = integralEnumFromThen + enumFromTo = integralEnumFromTo + enumFromThenTo = integralEnumFromThenTo + +instance Integral Int32 where + quot x@(I32# x#) y@(I32# y#) + | y /= 0 = I32# (x# `quotInt32#` y#) + | otherwise = divZeroError "quot{Int32}" x + rem x@(I32# x#) y@(I32# y#) + | y /= 0 = I32# (x# `remInt32#` y#) + | otherwise = divZeroError "rem{Int32}" x + div x@(I32# x#) y@(I32# y#) + | y /= 0 = I32# (x# `divInt32#` y#) + | otherwise = divZeroError "div{Int32}" x + mod x@(I32# x#) y@(I32# y#) + | y /= 0 = I32# (x# `modInt32#` y#) + | otherwise = divZeroError "mod{Int32}" x + quotRem x@(I32# x#) y@(I32# y#) + | y /= 0 = (I32# (x# `quotInt32#` y#), I32# (x# `remInt32#` y#)) + | otherwise = divZeroError "quotRem{Int32}" x + divMod x@(I32# x#) y@(I32# y#) + | y /= 0 = (I32# (x# `divInt32#` y#), I32# (x# `modInt32#` y#)) + | otherwise = divZeroError "divMod{Int32}" x + toInteger x@(I32# x#) + | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) + = S# (int32ToInt# x#) + | otherwise = case int32ToInteger# x# of (# s, d #) -> J# s d + +divInt32#, modInt32# :: Int32# -> Int32# -> Int32# +x# `divInt32#` y# + | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) + = ((x# `minusInt32#` y#) `minusInt32#` intToInt32# 1#) `quotInt32#` y# + | (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#) + = ((x# `minusInt32#` y#) `plusInt32#` intToInt32# 1#) `quotInt32#` y# + | otherwise = x# `quotInt32#` y# +x# `modInt32#` y# + | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) || + (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#) + = if r# `neInt32#` intToInt32# 0# then r# `plusInt32#` y# else intToInt32# 0# + | otherwise = r# + where + r# = x# `remInt32#` y# + +instance Read Int32 where + readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] + +instance Bits Int32 where + (I32# x#) .&. (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `and32#` int32ToWord32# y#)) + (I32# x#) .|. (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `or32#` int32ToWord32# y#)) + (I32# x#) `xor` (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `xor32#` int32ToWord32# y#)) + complement (I32# x#) = I32# (word32ToInt32# (not32# (int32ToWord32# x#))) + (I32# x#) `shift` (I# i#) + | i# >=# 0# = I32# (x# `iShiftL32#` i#) + | otherwise = I32# (x# `iShiftRA32#` negateInt# i#) + (I32# x#) `rotate` (I# i#) + | i'# ==# 0# + = I32# x# + | otherwise + = I32# (word32ToInt32# ((x'# `shiftL32#` i'#) `or32#` + (x'# `shiftRL32#` (32# -# i'#)))) + where + x'# = int32ToWord32# x# + i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) + bitSize _ = 32 + isSigned _ = True + +foreign import "stg_eqInt32" unsafe eqInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_neInt32" unsafe neInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_ltInt32" unsafe ltInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_leInt32" unsafe leInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_gtInt32" unsafe gtInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_geInt32" unsafe geInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_plusInt32" unsafe plusInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_minusInt32" unsafe minusInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_timesInt32" unsafe timesInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_negateInt32" unsafe negateInt32# :: Int32# -> Int32# +foreign import "stg_quotInt32" unsafe quotInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_remInt32" unsafe remInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_intToInt32" unsafe intToInt32# :: Int# -> Int32# +foreign import "stg_int32ToInt" unsafe int32ToInt# :: Int32# -> Int# +foreign import "stg_wordToWord32" unsafe wordToWord32# :: Word# -> Word32# +foreign import "stg_int32ToWord32" unsafe int32ToWord32# :: Int32# -> Word32# +foreign import "stg_word32ToInt32" unsafe word32ToInt32# :: Word32# -> Int32# +foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# -> Word32# +foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32# +foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32# +foreign import "stg_not32" unsafe not32# :: Word32# -> Word32# +foreign import "stg_iShiftL32" unsafe iShiftL32# :: Int32# -> Int# -> Int32# +foreign import "stg_iShiftRA32" unsafe iShiftRA32# :: Int32# -> Int# -> Int32# +foreign import "stg_shiftL32" unsafe shiftL32# :: Word32# -> Int# -> Word32# +foreign import "stg_shiftRL32" unsafe shiftRL32# :: Word32# -> Int# -> Word32# + +{-# RULES +"fromIntegral/Int->Int32" fromIntegral = \(I# x#) -> I32# (intToInt32# x#) +"fromIntegral/Word->Int32" fromIntegral = \(W# x#) -> I32# (word32ToInt32# (wordToWord32# x#)) +"fromIntegral/Word32->Int32" fromIntegral = \(W32# x#) -> I32# (word32ToInt32# x#) +"fromIntegral/Int32->Int" fromIntegral = \(I32# x#) -> I# (int32ToInt# x#) +"fromIntegral/Int32->Word" fromIntegral = \(I32# x#) -> W# (int2Word# (int32ToInt# x#)) +"fromIntegral/Int32->Word32" fromIntegral = \(I32# x#) -> W32# (int32ToWord32# x#) +"fromIntegral/Int32->Int32" fromIntegral = id :: Int32 -> Int32 + #-} + +#else + -- Int32 is represented in the same way as Int. -#if WORD_SIZE_IN_BYTES == 8 +#if WORD_SIZE_IN_BITS > 32 -- Operations may assume and must ensure that it holds only values -- from its logical range. #endif data Int32 = I32# Int# deriving (Eq, Ord) -instance CCallable Int32 -instance CReturnable Int32 - instance Show Int32 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Int32 where - (I32# x#) + (I32# y#) = I32# (intToInt32# (x# +# y#)) - (I32# x#) - (I32# y#) = I32# (intToInt32# (x# -# y#)) - (I32# x#) * (I32# y#) = I32# (intToInt32# (x# *# y#)) - negate (I32# x#) = I32# (intToInt32# (negateInt# x#)) + (I32# x#) + (I32# y#) = I32# (narrow32Int# (x# +# y#)) + (I32# x#) - (I32# y#) = I32# (narrow32Int# (x# -# y#)) + (I32# x#) * (I32# y#) = I32# (narrow32Int# (x# *# y#)) + negate (I32# x#) = I32# (narrow32Int# (negateInt# x#)) abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger (S# i#) = I32# (intToInt32# i#) - fromInteger (J# s# d#) = I32# (intToInt32# (integer2Int# s# d#)) - -instance Real Int32 where - toRational x = toInteger x % 1 + fromInteger (S# i#) = I32# (narrow32Int# i#) + fromInteger (J# s# d#) = I32# (narrow32Int# (integer2Int# s# d#)) instance Enum Int32 where succ x @@ -278,7 +423,7 @@ instance Enum Int32 where pred x | x /= minBound = x - 1 | otherwise = predError "Int32" -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS == 32 toEnum (I# i#) = I32# i# #else toEnum i@(I# i#) @@ -292,38 +437,27 @@ instance Enum Int32 where instance Integral Int32 where quot x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (intToInt32# (x# `quotInt#` y#)) + | y /= 0 = I32# (narrow32Int# (x# `quotInt#` y#)) | otherwise = divZeroError "quot{Int32}" x rem x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (intToInt32# (x# `remInt#` y#)) + | y /= 0 = I32# (narrow32Int# (x# `remInt#` y#)) | otherwise = divZeroError "rem{Int32}" x div x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (intToInt32# (x# `divInt#` y#)) + | y /= 0 = I32# (narrow32Int# (x# `divInt#` y#)) | otherwise = divZeroError "div{Int32}" x mod x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (intToInt32# (x# `modInt#` y#)) + | y /= 0 = I32# (narrow32Int# (x# `modInt#` y#)) | otherwise = divZeroError "mod{Int32}" x quotRem x@(I32# x#) y@(I32# y#) - | y /= 0 = (I32# (intToInt32# (x# `quotInt#` y#)), - I32# (intToInt32# (x# `remInt#` y#))) + | y /= 0 = (I32# (narrow32Int# (x# `quotInt#` y#)), + I32# (narrow32Int# (x# `remInt#` y#))) | otherwise = divZeroError "quotRem{Int32}" x divMod x@(I32# x#) y@(I32# y#) - | y /= 0 = (I32# (intToInt32# (x# `divInt#` y#)), - I32# (intToInt32# (x# `modInt#` y#))) + | y /= 0 = (I32# (narrow32Int# (x# `divInt#` y#)), + I32# (narrow32Int# (x# `modInt#` y#))) | otherwise = divZeroError "divMod{Int32}" x toInteger (I32# x#) = S# x# -instance Bounded Int32 where - minBound = -0x80000000 - maxBound = 0x7FFFFFFF - -instance Ix Int32 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Int32" - inRange (m,n) i = m <= i && i <= n - instance Read Int32 where readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] @@ -333,13 +467,16 @@ instance Bits Int32 where (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I32# x#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I32# x#) `shift` (I# i#) - | i# >=# 0# = I32# (intToInt32# (x# `iShiftL#` i#)) + | i# >=# 0# = I32# (narrow32Int# (x# `iShiftL#` i#)) | otherwise = I32# (x# `iShiftRA#` negateInt# i#) - (I32# x#) `rotate` (I# i#) = - I32# (intToInt32# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (32# -# i'#))))) + (I32# x#) `rotate` (I# i#) + | i'# ==# 0# + = I32# x# + | otherwise + = I32# (narrow32Int# (word2Int# ((x'# `shiftL#` i'#) `or#` + (x'# `shiftRL#` (32# -# i'#))))) where - x'# = wordToWord32# (int2Word# x#) + x'# = narrow32Word# (int2Word# x#) i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) bitSize _ = 32 isSigned _ = True @@ -350,15 +487,33 @@ instance Bits Int32 where "fromIntegral/Int8->Int32" fromIntegral = \(I8# x#) -> I32# x# "fromIntegral/Int16->Int32" fromIntegral = \(I16# x#) -> I32# x# "fromIntegral/Int32->Int32" fromIntegral = id :: Int32 -> Int32 -"fromIntegral/a->Int32" fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (intToInt32# x#) +"fromIntegral/a->Int32" fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (narrow32Int# x#) "fromIntegral/Int32->a" fromIntegral = \(I32# x#) -> fromIntegral (I# x#) #-} +#endif + +instance CCallable Int32 +instance CReturnable Int32 + +instance Real Int32 where + toRational x = toInteger x % 1 + +instance Bounded Int32 where + minBound = -0x80000000 + maxBound = 0x7FFFFFFF + +instance Ix Int32 where + range (m,n) = [m..n] + unsafeIndex b@(m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + ------------------------------------------------------------------------ -- type Int64 ------------------------------------------------------------------------ -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS < 64 data Int64 = I64# Int64# @@ -425,10 +580,11 @@ instance Integral Int64 where | y /= 0 = (I64# (x# `divInt64#` y#), I64# (x# `modInt64#` y#)) | otherwise = divZeroError "divMod{Int64}" x toInteger x@(I64# x#) - | x >= -0x80000000 && x <= 0x7FFFFFFF + | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) = S# (int64ToInt# x#) | otherwise = case int64ToInteger# x# of (# s, d #) -> J# s d + divInt64#, modInt64# :: Int64# -> Int64# -> Int64# x# `divInt64#` y# | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#) @@ -455,9 +611,12 @@ instance Bits Int64 where (I64# x#) `shift` (I# i#) | i# >=# 0# = I64# (x# `iShiftL64#` i#) | otherwise = I64# (x# `iShiftRA64#` negateInt# i#) - (I64# x#) `rotate` (I# i#) = - I64# (word64ToInt64# ((x'# `shiftL64#` i'#) `or64#` - (x'# `shiftRL64#` (64# -# i'#)))) + (I64# x#) `rotate` (I# i#) + | i'# ==# 0# + = I64# x# + | otherwise + = I64# (word64ToInt64# ((x'# `shiftL64#` i'#) `or64#` + (x'# `shiftRL64#` (64# -# i'#)))) where x'# = int64ToWord64# x# i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) @@ -490,6 +649,8 @@ foreign import "stg_iShiftRA64" unsafe iShiftRA64# :: Int64# -> Int# -> In foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64# foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64# +foreign import "stg_integerToInt64" unsafe integerToInt64# :: Int# -> ByteArray# -> Int64# + {-# RULES "fromIntegral/Int->Int64" fromIntegral = \(I# x#) -> I64# (intToInt64# x#) "fromIntegral/Word->Int64" fromIntegral = \(W# x#) -> I64# (word64ToInt64# (wordToWord64# x#)) @@ -500,7 +661,11 @@ foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> W "fromIntegral/Int64->Int64" fromIntegral = id :: Int64 -> Int64 #-} -#else +#else + +-- Int64 is represented in the same way as Int. +-- Operations may assume and must ensure that it holds only values +-- from its logical range. data Int64 = I64# Int# deriving (Eq, Ord) @@ -564,9 +729,12 @@ instance Bits Int64 where (I64# x#) `shift` (I# i#) | i# >=# 0# = I64# (x# `iShiftL#` i#) | otherwise = I64# (x# `iShiftRA#` negateInt# i#) - (I64# x#) `rotate` (I# i#) = - I64# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (64# -# i'#)))) + (I64# x#) `rotate` (I# i#) + | i'# ==# 0# + = I64# x# + | otherwise + = I64# (word2Int# ((x'# `shiftL#` i'#) `or#` + (x'# `shiftRL#` (64# -# i'#)))) where x'# = int2Word# x# i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) @@ -591,9 +759,8 @@ instance Bounded Int64 where maxBound = 0x7FFFFFFFFFFFFFFF instance Ix Int64 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Int64" - inRange (m,n) i = m <= i && i <= n + range (m,n) = [m..n] + unsafeIndex b@(m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 \end{code} diff --git a/GHC/List.lhs b/GHC/List.lhs index 5c887ec..b7f4beb 100644 --- a/GHC/List.lhs +++ b/GHC/List.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: List.lhs,v 1.4 2001/07/31 13:14:01 simonmar Exp $ +% $Id: List.lhs,v 1.5 2001/12/21 15:07:25 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -118,9 +118,11 @@ length l = len l 0# -- filter, applied to a predicate and a list, returns the list of those -- elements that satisfy the predicate; i.e., -- filter p xs = [ x | x <- xs, p x] +{-# NOINLINE [1] filter #-} filter :: (a -> Bool) -> [a] -> [a] filter = filterList +{-# INLINE [0] filter #-} filterFB c p x r | p x = x `c` r | otherwise = r @@ -176,9 +178,9 @@ scanl f q ls = q : (case ls of [] -> [] x:xs -> scanl f (f q x) xs) -scanl1 :: (a -> a -> a) -> [a] -> [a] -scanl1 f (x:xs) = scanl f x xs -scanl1 _ [] = errorEmptyList "scanl1" +scanl1 :: (a -> a -> a) -> [a] -> [a] +scanl1 f (x:xs) = scanl f x xs +scanl1 _ [] = [] -- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the -- above functions. @@ -194,14 +196,15 @@ scanr f q0 (x:xs) = f x q : qs where qs@(q:_) = scanr f q0 xs scanr1 :: (a -> a -> a) -> [a] -> [a] -scanr1 _ [x] = [x] -scanr1 f (x:xs) = f x q : qs +scanr1 f [] = [] +scanr1 f [x] = [x] +scanr1 f (x:xs) = f x q : qs where qs@(q:_) = scanr1 f xs -scanr1 _ [] = errorEmptyList "scanr1" -- iterate f x returns an infinite list of repeated applications of f to x: -- iterate f x == [x, f x, f (f x), ...] iterate :: (a -> a) -> a -> [a] +{-# NOINLINE [1] iterate #-} iterate = iterateList iterateFB c f x = x `c` iterateFB c f (f x) @@ -216,9 +219,12 @@ iterateList f x = x : iterateList f (f x) -- repeat x is an infinite list, with x the value of every element. repeat :: a -> [a] +{-# NOINLINE [1] repeat #-} repeat = repeatList +{-# INLINE [0] repeatFB #-} repeatFB c x = xs where xs = x `c` xs + repeatList x = xs where xs = x : xs {-# RULES @@ -447,10 +453,10 @@ concat = foldr (++) [] -- List index (subscript) operator, 0-origin (!!) :: [a] -> Int -> a #ifdef USE_REPORT_PRELUDE -(x:_) !! 0 = x -(_:xs) !! n | n > 0 = xs !! (minusInt n 1) -(_:_) !! _ = error "Prelude.(!!): negative index" -[] !! _ = error "Prelude.(!!): index too large" +xs !! n | n < 0 = error "Prelude.!!: negative index" +[] !! _ = error "Prelude.!!: index too large" +(x:_) !! 0 = x +(_:xs) !! n = xs !! (n-1) #else -- HBC version (stolen), then unboxified -- The semantics is not quite the same for error conditions @@ -514,8 +520,10 @@ tuples are in the List module. \begin{code} ---------------------------------------------- zip :: [a] -> [b] -> [(a,b)] +{-# NOINLINE [1] zip #-} zip = zipList +{-# INLINE [0] zipFB #-} zipFB c x y r = (x,y) `c` r @@ -548,9 +556,10 @@ zip3 _ _ _ = [] \begin{code} ---------------------------------------------- zipWith :: (a->b->c) -> [a]->[b]->[c] +{-# NOINLINE [1] zipWith #-} zipWith = zipWithList - +{-# INLINE [0] zipWithFB #-} zipWithFB c f x y r = (x `f` y) `c` r zipWithList :: (a->b->c) -> [a] -> [b] -> [c] diff --git a/GHC/Num.lhs b/GHC/Num.lhs index 611236c..8bc005b 100644 --- a/GHC/Num.lhs +++ b/GHC/Num.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: Num.lhs,v 1.2 2001/07/31 13:09:11 simonmar Exp $ +% $Id: Num.lhs,v 1.3 2001/12/21 15:07:25 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -19,12 +19,12 @@ and the type {-# OPTIONS -fno-implicit-prelude #-} #include "MachDeps.h" -#if WORD_SIZE_IN_BYTES == 4 +#if SIZEOF_HSWORD == 4 #define LEFTMOST_BIT 2147483648 -#elif WORD_SIZE_IN_BYTES == 8 +#elif SIZEOF_HSWORD == 8 #define LEFTMOST_BIT 9223372036854775808 #else -#error Please define LEFTMOST_BIT to be 2^(WORD_SIZE_IN_BYTES*8-1) +#error Please define LEFTMOST_BIT to be 2^(SIZEOF_HSWORD*8-1) #endif module GHC.Num where @@ -109,7 +109,13 @@ divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y) \begin{code} data Integer = S# Int# -- small integers +#ifndef ILX | J# Int# ByteArray# -- large integers +#else + | J# Void BigInteger -- .NET big ints + +foreign type dotnet "BigInteger" BigInteger +#endif \end{code} Convenient boxed Integer PrimOps. @@ -346,9 +352,9 @@ minusInteger i1@(J# _ _) i2@(S# _) = i1 - toBig i2 minusInteger i1@(S# _) i2@(J# _ _) = toBig i1 - i2 minusInteger (J# s1 d1) (J# s2 d2) = case minusInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d -timesInteger i1@(S# i) i2@(S# j) = case mulIntC# i j of { (# r, c #) -> - if c ==# 0# then S# r - else toBig i1 * toBig i2 } +timesInteger i1@(S# i) i2@(S# j) = if mulIntMayOflo# i j ==# 0# + then S# (i *# j) + else toBig i1 * toBig i2 timesInteger i1@(J# _ _) i2@(S# _) = i1 * toBig i2 timesInteger i1@(S# _) i2@(J# _ _) = toBig i1 * i2 timesInteger (J# s1 d1) (J# s2 d2) = case timesInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d @@ -436,7 +442,10 @@ dn_list x delta lim = go (x::Integer) \begin{code} instance Show Integer where showsPrec p n r - | n < 0 && p > 6 = '(' : jtos n (')' : r) + | p > 6 && n < 0 = '(' : jtos n (')' : r) + -- Minor point: testing p first gives better code + -- in the not-uncommon case where the p argument + -- is a constant | otherwise = jtos n r showList = showList__ (showsPrec 0) diff --git a/GHC/Posix.hsc b/GHC/Posix.hsc index 819beea..339f9bb 100644 --- a/GHC/Posix.hsc +++ b/GHC/Posix.hsc @@ -1,7 +1,7 @@ {-# OPTIONS -fno-implicit-prelude #-} -- --------------------------------------------------------------------------- --- $Id: Posix.hsc,v 1.3 2001/08/17 12:50:34 simonmar Exp $ +-- $Id: Posix.hsc,v 1.4 2001/12/21 15:07:25 simonmar Exp $ -- -- POSIX support layer for the standard libraries -- @@ -90,6 +90,8 @@ fileType file = c_stat p_file p_stat statGetType p_stat +-- NOTE: On Win32 platforms, this will only work with file descriptors +-- referring to file handles. i.e., it'll fail for socket FDs. fdType :: Int -> IO FDType fdType fd = allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do @@ -121,6 +123,16 @@ fileTruncate file = do c_close fd return () +#ifdef mingw32_TARGET_OS +closeFd :: Bool -> CInt -> IO CInt +closeFd isStream fd + | isStream = c_closesocket fd + | otherwise = c_close fd + +foreign import "closesocket" unsafe + c_closesocket :: CInt -> IO CInt +#endif + -- --------------------------------------------------------------------------- -- Terminal-related stuff @@ -209,9 +221,11 @@ getEcho fd = return False setNonBlockingFD fd = do flags <- throwErrnoIfMinus1Retry "setNonBlockingFD" (c_fcntl_read (fromIntegral fd) (#const F_GETFL)) - throwErrnoIfMinus1Retry "setNonBlockingFD" - (c_fcntl_write (fromIntegral fd) - (#const F_SETFL) (flags .|. #const O_NONBLOCK)) + -- An error when setting O_NONBLOCK isn't fatal: on some systems + -- there are certain file handles on which this will fail (eg. /dev/null + -- on FreeBSD) so we throw away the return code from fcntl_write. + fcntl_write (fromIntegral fd) + (#const F_SETFL) (flags .|. #const O_NONBLOCK) #else -- bogus defns for win32 @@ -355,7 +369,7 @@ foreign import ccall "fcntl" unsafe foreign import ccall "fork" unsafe c_fork :: IO CPid -foreign import ccall "sigemptyset" unsafe +foreign import ccall "sigemptyset_wrap" unsafe c_sigemptyset :: Ptr CSigset -> IO () foreign import ccall "sigaddset" unsafe diff --git a/GHC/Prim.hi-boot b/GHC/Prim.hi-boot.pp similarity index 88% rename from GHC/Prim.hi-boot rename to GHC/Prim.hi-boot.pp index 2b7d8bb..84d7edc 100644 --- a/GHC/Prim.hi-boot +++ b/GHC/Prim.hi-boot.pp @@ -1,10 +1,12 @@ --------------------------------------------------------------------------- --- PrelGHC.hi-boot +-- GHC/Prim.hi-boot -- -- This hand-written interface file allows you to bring into scope the -- primitive operations and types that GHC knows about. --------------------------------------------------------------------------- +#include "MachDeps.h" + __interface "core" GHCziPrim 1 0 where __export GHCziPrim @@ -49,6 +51,9 @@ __export GHCziPrim tryPutMVarzh isEmptyMVarzh + -- Seq + seq -- Defined in MkId + -- Parallel seqzh parzh @@ -85,12 +90,12 @@ __export GHCziPrim remIntzh gcdIntzh negateIntzh - iShiftLzh - iShiftRAzh - iShiftRLzh + uncheckedIShiftLzh + uncheckedIShiftRAzh + uncheckedIShiftRLzh addIntCzh subIntCzh - mulIntCzh + mulIntMayOflozh Wordzh gtWordzh @@ -108,30 +113,43 @@ __export GHCziPrim orzh notzh xorzh - shiftLzh - shiftRLzh + uncheckedShiftLzh + uncheckedShiftRLzh int2Wordzh word2Intzh + narrow8Intzh + narrow16Intzh + narrow32Intzh + narrow8Wordzh + narrow16Wordzh + narrow32Wordzh + +#if WORD_SIZE_IN_BITS < 32 + Int32zh + Word32zh +#endif + +#if WORD_SIZE_IN_BITS < 64 Int64zh Word64zh - - intToInt8zh - intToInt16zh - intToInt32zh - wordToWord8zh - wordToWord16zh - wordToWord32zh +#endif Addrzh + nullAddrzh -- Defined in MkId + plusAddrzh + minusAddrzh + remAddrzh +#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64) + addr2Intzh + int2Addrzh +#endif gtAddrzh geAddrzh eqAddrzh neAddrzh ltAddrzh leAddrzh - int2Addrzh - addr2Intzh Floatzh gtFloatzh @@ -193,6 +211,9 @@ __export GHCziPrim ztztzhzh decodeDoublezh +-- Integer is implemented by foreign imports on .NET, so no primops + +#ifndef ILX cmpIntegerzh cmpIntegerIntzh plusIntegerzh @@ -210,14 +231,21 @@ __export GHCziPrim integer2Wordzh int2Integerzh word2Integerzh - integerToInt64zh - integerToWord64zh +#if WORD_SIZE_IN_BITS < 32 + integerToInt32zh + integerToWord32zh + int32ToIntegerzh + word32ToIntegerzh +#endif +#if WORD_SIZE_IN_BITS < 64 int64ToIntegerzh word64ToIntegerzh +#endif andIntegerzh orIntegerzh xorIntegerzh complementIntegerzh +#endif Arrayzh ByteArrayzh @@ -392,19 +420,19 @@ __export GHCziPrim eqStableNamezh stableNameToIntzh - reallyUnsafePtrEqualityzh - newBCOzh BCOzh mkApUpd0zh - unsafeCoercezh + unsafeCoercezh -- unsafeCoerce# :: forall a b. a -> b + -- It's defined in ghc/compiler/basicTypes/MkId.lhs addrToHValuezh ; --- Export GHC.Err.error, so that others don't have to import PrelErr +-- Export GHC.Err.error, so that others do not have to import PrelErr __export GHCziErr error ; +infixr 0 seq ; -------------------------------------------------- instance {CCallable Charzh} = zdfCCallableCharzh; @@ -426,7 +454,7 @@ instance __forall s => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; 1 assert :: __forall a => GHCziBase.Bool -> a -> a ; --- These guys don't really exist: +-- These guys do not really exist: -- 1 zdfCCallableCharzh :: {CCallable Charzh} ; 1 zdfCCallableDoublezh :: {CCallable Doublezh} ; @@ -440,3 +468,4 @@ instance __forall s => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; 1 zdfCCallableMutableByteArrayzh :: __forall s => {CCallable (MutableByteArrayzh s)} ; 1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ; 1 zdfCCallableStablePtrzh :: __forall a => {CCallable (StablePtrzh a)} ; + diff --git a/GHC/Ptr.lhs b/GHC/Ptr.lhs index 61b7f3e..dc6186a 100644 --- a/GHC/Ptr.lhs +++ b/GHC/Ptr.lhs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Ptr.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $ +-- $Id: Ptr.lhs,v 1.2 2001/12/21 15:07:25 simonmar Exp $ -- -- (c) The FFI Task Force, 2000 -- @@ -17,23 +17,22 @@ import GHC.Base data Ptr a = Ptr Addr# deriving (Eq, Ord) nullPtr :: Ptr a -nullPtr = Ptr (int2Addr# 0#) +nullPtr = Ptr nullAddr# castPtr :: Ptr a -> Ptr b castPtr (Ptr addr) = Ptr addr plusPtr :: Ptr a -> Int -> Ptr b -plusPtr (Ptr addr) (I# d) = Ptr (int2Addr# (addr2Int# addr +# d)) +plusPtr (Ptr addr) (I# d) = Ptr (plusAddr# addr d) alignPtr :: Ptr a -> Int -> Ptr a alignPtr addr@(Ptr a) (I# i) - = case addr2Int# a of { ai -> - case remInt# ai i of { + = case remAddr# a i of { 0# -> addr; - n -> Ptr (int2Addr# (ai +# (i -# n))) }} + n -> Ptr (plusAddr# a (i -# n)) } minusPtr :: Ptr a -> Ptr b -> Int -minusPtr (Ptr a1) (Ptr a2) = I# (addr2Int# a1 -# addr2Int# a2) +minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2) instance CCallable (Ptr a) instance CReturnable (Ptr a) @@ -44,7 +43,7 @@ instance CReturnable (Ptr a) data FunPtr a = FunPtr Addr# deriving (Eq, Ord) nullFunPtr :: FunPtr a -nullFunPtr = FunPtr (int2Addr# 0#) +nullFunPtr = FunPtr nullAddr# castFunPtr :: FunPtr a -> FunPtr b castFunPtr (FunPtr addr) = FunPtr addr @@ -59,3 +58,4 @@ instance CCallable (FunPtr a) instance CReturnable (FunPtr a) \end{code} + diff --git a/GHC/Read.lhs b/GHC/Read.lhs index 5332c63..a01c8e2 100644 --- a/GHC/Read.lhs +++ b/GHC/Read.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: Read.lhs,v 1.2 2001/07/03 14:13:32 simonmar Exp $ +% $Id: Read.lhs,v 1.3 2001/12/21 15:07:25 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -373,7 +373,7 @@ instance (Integral a, Read a) => Read (Ratio a) where (x,s) <- reads r ("%",t) <- lex s (y,u) <- reads t - return (x%y,u)) + return (x % y,u)) instance (Read a) => Read [a] where readsPrec _ = readList @@ -554,23 +554,22 @@ point type to obtain the same results. ReadS Double, ReadS Float #-} readFloat :: (RealFloat a) => ReadS a -readFloat r = do - (x,t) <- readRational r - return (fromRational x,t) - -readRational :: ReadS Rational -- NB: doesn't handle leading "-" - -readRational r = - (do - (n,d,s) <- readFix r - (k,t) <- readExp s - return ((n%1)*10^^(k-d), t )) ++ +readFloat r = + (do + (x,t) <- readRational r + return (fromRational x,t) ) ++ (do ("NaN",t) <- lex r return (0/0,t) ) ++ (do ("Infinity",t) <- lex r return (1/0,t) ) + +readRational :: ReadS Rational -- NB: doesn't handle leading "-" +readRational r = do + (n,d,s) <- readFix r + (k,t) <- readExp s + return ((n%1)*10^^(k-d), t) where readFix r = do (ds,s) <- lexDecDigits r diff --git a/GHC/Real.lhs b/GHC/Real.lhs index b453f6b..0c27ce3 100644 --- a/GHC/Real.lhs +++ b/GHC/Real.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: Real.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $ +% $Id: Real.lhs,v 1.2 2001/12/21 15:07:25 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -62,6 +62,7 @@ their greatest common divisor. \begin{code} reduce :: (Integral a) => a -> a -> Ratio a +{-# SPECIALISE reduce :: Integer -> Integer -> Rational #-} reduce _ 0 = error "Ratio.%: zero denominator" reduce x y = (x `quot` d) :% (y `quot` d) where d = gcd x y @@ -226,7 +227,7 @@ instance (Integral a) => Num (Ratio a) where instance (Integral a) => Fractional (Ratio a) where {-# SPECIALIZE instance Fractional Rational #-} (x:%y) / (x':%y') = (x*y') % (y*x') - recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x + recip (x:%y) = y % x fromRational (x:%y) = fromInteger x :% fromInteger y instance (Integral a) => Real (Ratio a) where diff --git a/GHC/ST.lhs b/GHC/ST.lhs index f98b33d..c36292c 100644 --- a/GHC/ST.lhs +++ b/GHC/ST.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: ST.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $ +% $Id: ST.lhs,v 1.2 2001/12/21 15:07:25 simonmar Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -118,9 +118,9 @@ runST :: (forall s. ST s a) -> a runST st = runSTRep (case st of { ST st_rep -> st_rep }) -- I'm only letting runSTRep be inlined right at the end, in particular *after* full laziness --- That's what the "INLINE 100" says. +-- That's what the "INLINE [0]" says. -- SLPJ Apr 99 -{-# INLINE 100 runSTRep #-} +{-# INLINE [0] runSTRep #-} runSTRep :: (forall s. STRep s a) -> a runSTRep st_rep = case st_rep realWorld# of (# _, r #) -> r diff --git a/GHC/STRef.lhs b/GHC/STRef.lhs index cf9cea5..7145932 100644 --- a/GHC/STRef.lhs +++ b/GHC/STRef.lhs @@ -3,7 +3,6 @@ module GHC.STRef where import GHC.ST -import GHC.Prim import GHC.Base data STRef s a = STRef (MutVar# s a) diff --git a/GHC/Show.lhs b/GHC/Show.lhs index 3f83519..9a14dae 100644 --- a/GHC/Show.lhs +++ b/GHC/Show.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: Show.lhs,v 1.3 2001/07/03 14:13:32 simonmar Exp $ +% $Id: Show.lhs,v 1.4 2001/12/21 15:07:25 simonmar Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -246,8 +246,8 @@ itos n# cs itos' :: Int# -> String -> String itos' n# cs | n# <# 10# = C# (chr# (ord# '0'# +# n#)) : cs - | otherwise = itos' (n# `quotInt#` 10#) - (C# (chr# (ord# '0'# +# (n# `remInt#` 10#))) : cs) + | otherwise = case chr# (ord# '0'# +# (n# `remInt#` 10#)) of { c# -> + itos' (n# `quotInt#` 10#) (C# c# : cs) } \end{code} %********************************************************* diff --git a/GHC/Storable.lhs b/GHC/Storable.lhs index 4868c6d..afbbb9d 100644 --- a/GHC/Storable.lhs +++ b/GHC/Storable.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: Storable.lhs,v 1.2 2001/07/31 13:10:01 simonmar Exp $ +% $Id: Storable.lhs,v 1.3 2001/12/21 15:07:25 simonmar Exp $ % % (c) The FFI task force, 2000 % @@ -106,25 +106,25 @@ instance Storable (T) where { \ STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32, readWideCharOffPtr,writeWideCharOffPtr) -STORABLE(Int,SIZEOF_LONG,ALIGNMENT_LONG, +STORABLE(Int,SIZEOF_HSINT,ALIGNMENT_HSINT, readIntOffPtr,writeIntOffPtr) -STORABLE(Word,SIZEOF_LONG,ALIGNMENT_LONG, +STORABLE(Word,SIZEOF_HSWORD,ALIGNMENT_HSWORD, readWordOffPtr,writeWordOffPtr) -STORABLE((Ptr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P, +STORABLE((Ptr a),SIZEOF_HSPTR,ALIGNMENT_HSPTR, readPtrOffPtr,writePtrOffPtr) -STORABLE((FunPtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P, +STORABLE((FunPtr a),SIZEOF_HSFUNPTR,ALIGNMENT_HSFUNPTR, readFunPtrOffPtr,writeFunPtrOffPtr) -STORABLE((StablePtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P, +STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR, readStablePtrOffPtr,writeStablePtrOffPtr) -STORABLE(Float,SIZEOF_FLOAT,ALIGNMENT_FLOAT, +STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT, readFloatOffPtr,writeFloatOffPtr) -STORABLE(Double,SIZEOF_DOUBLE,ALIGNMENT_DOUBLE, +STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE, readDoubleOffPtr,writeDoubleOffPtr) STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8, @@ -220,30 +220,20 @@ readStablePtrOffPtr (Ptr a) (I# i) = IO $ \s -> case readStablePtrOffAddr# a i s of (# s2, x #) -> (# s2, StablePtr x #) readInt8OffPtr (Ptr a) (I# i) = IO $ \s -> case readInt8OffAddr# a i s of (# s2, x #) -> (# s2, I8# x #) -readInt16OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# x #) -readInt32OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# x #) -#if WORD_SIZE_IN_BYTES == 4 -readInt64OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt64OffAddr# a i s of (# s2, x #) -> (# s2, I64# x #) -#else -readInt64OffPtr (Ptr a) (I# i) - = IO $ \s -> case readIntOffAddr# a i s of (# s2, x #) -> (# s2, I64# x #) -#endif readWord8OffPtr (Ptr a) (I# i) = IO $ \s -> case readWord8OffAddr# a i s of (# s2, x #) -> (# s2, W8# x #) +readInt16OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# x #) readWord16OffPtr (Ptr a) (I# i) = IO $ \s -> case readWord16OffAddr# a i s of (# s2, x #) -> (# s2, W16# x #) +readInt32OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# x #) readWord32OffPtr (Ptr a) (I# i) = IO $ \s -> case readWord32OffAddr# a i s of (# s2, x #) -> (# s2, W32# x #) -#if WORD_SIZE_IN_BYTES == 4 +readInt64OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt64OffAddr# a i s of (# s2, x #) -> (# s2, I64# x #) readWord64OffPtr (Ptr a) (I# i) = IO $ \s -> case readWord64OffAddr# a i s of (# s2, x #) -> (# s2, W64# x #) -#else -readWord64OffPtr (Ptr a) (I# i) - = IO $ \s -> case readWordOffAddr# a i s of (# s2, x #) -> (# s2, W64# x #) -#endif writeWideCharOffPtr :: Ptr Char -> Int -> Char -> IO () writeIntOffPtr :: Ptr Int -> Int -> Int -> IO () @@ -280,30 +270,20 @@ writeStablePtrOffPtr (Ptr a) (I# i) (StablePtr x) = IO $ \s -> case writeStablePtrOffAddr# a i x s of s2 -> (# s2 , () #) writeInt8OffPtr (Ptr a) (I# i) (I8# x) = IO $ \s -> case writeInt8OffAddr# a i x s of s2 -> (# s2, () #) -writeInt16OffPtr (Ptr a) (I# i) (I16# x) - = IO $ \s -> case writeInt16OffAddr# a i x s of s2 -> (# s2, () #) -writeInt32OffPtr (Ptr a) (I# i) (I32# x) - = IO $ \s -> case writeInt32OffAddr# a i x s of s2 -> (# s2, () #) -#if WORD_SIZE_IN_BYTES == 4 -writeInt64OffPtr (Ptr a) (I# i) (I64# x) - = IO $ \s -> case writeInt64OffAddr# a i x s of s2 -> (# s2, () #) -#else -writeInt64OffPtr (Ptr a) (I# i) (I64# x) - = IO $ \s -> case writeIntOffAddr# a i x s of s2 -> (# s2, () #) -#endif writeWord8OffPtr (Ptr a) (I# i) (W8# x) = IO $ \s -> case writeWord8OffAddr# a i x s of s2 -> (# s2, () #) +writeInt16OffPtr (Ptr a) (I# i) (I16# x) + = IO $ \s -> case writeInt16OffAddr# a i x s of s2 -> (# s2, () #) writeWord16OffPtr (Ptr a) (I# i) (W16# x) = IO $ \s -> case writeWord16OffAddr# a i x s of s2 -> (# s2, () #) +writeInt32OffPtr (Ptr a) (I# i) (I32# x) + = IO $ \s -> case writeInt32OffAddr# a i x s of s2 -> (# s2, () #) writeWord32OffPtr (Ptr a) (I# i) (W32# x) = IO $ \s -> case writeWord32OffAddr# a i x s of s2 -> (# s2, () #) -#if WORD_SIZE_IN_BYTES == 4 +writeInt64OffPtr (Ptr a) (I# i) (I64# x) + = IO $ \s -> case writeInt64OffAddr# a i x s of s2 -> (# s2, () #) writeWord64OffPtr (Ptr a) (I# i) (W64# x) = IO $ \s -> case writeWord64OffAddr# a i x s of s2 -> (# s2, () #) -#else -writeWord64OffPtr (Ptr a) (I# i) (W64# x) - = IO $ \s -> case writeWordOffAddr# a i x s of s2 -> (# s2, () #) -#endif #endif /* __GLASGOW_HASKELL__ */ \end{code} diff --git a/GHC/Weak.lhs b/GHC/Weak.lhs index 95dd3a5..25515ba 100644 --- a/GHC/Weak.lhs +++ b/GHC/Weak.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: Weak.lhs,v 1.2 2001/07/03 14:13:32 simonmar Exp $ +% $Id: Weak.lhs,v 1.3 2001/12/21 15:07:25 simonmar Exp $ % % (c) The University of Glasgow, 1998-2000 % @@ -11,7 +11,6 @@ module GHC.Weak where -import GHC.Prim import GHC.Base import Data.Maybe import GHC.IOBase ( IO(..), unIO ) diff --git a/GHC/Word.lhs b/GHC/Word.lhs index fe847fc..06a5c24 100644 --- a/GHC/Word.lhs +++ b/GHC/Word.lhs @@ -132,18 +132,19 @@ instance Integral Word where instance Bounded Word where minBound = 0 -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS == 31 + maxBound = 0x7FFFFFFF +#elif WORD_SIZE_IN_BITS == 32 maxBound = 0xFFFFFFFF #else maxBound = 0xFFFFFFFFFFFFFFFF #endif instance Ix Word where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Word" - inRange (m,n) i = m <= i && i <= n + range (m,n) = [m..n] + unsafeIndex b@(m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 instance Read Word where readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] @@ -156,16 +157,13 @@ instance Bits Word where (W# x#) `shift` (I# i#) | i# >=# 0# = W# (x# `shiftL#` i#) | otherwise = W# (x# `shiftRL#` negateInt# i#) -#if WORD_SIZE_IN_BYTES == 4 - (W# x#) `rotate` (I# i#) = W# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (32# -# i'#))) + (W# x#) `rotate` (I# i#) + | i'# ==# 0# = W# x# + | otherwise = W# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (wsib -# i'#))) where - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) -#else - (W# x#) `rotate` (I# i#) = W# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (64# -# i'#))) - where - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) -#endif - bitSize _ = WORD_SIZE_IN_BYTES * 8 + i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) + wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + bitSize _ = WORD_SIZE_IN_BITS isSigned _ = False {-# RULES @@ -190,15 +188,15 @@ instance Show Word8 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Word8 where - (W8# x#) + (W8# y#) = W8# (wordToWord8# (x# `plusWord#` y#)) - (W8# x#) - (W8# y#) = W8# (wordToWord8# (x# `minusWord#` y#)) - (W8# x#) * (W8# y#) = W8# (wordToWord8# (x# `timesWord#` y#)) - negate (W8# x#) = W8# (wordToWord8# (int2Word# (negateInt# (word2Int# x#)))) + (W8# x#) + (W8# y#) = W8# (narrow8Word# (x# `plusWord#` y#)) + (W8# x#) - (W8# y#) = W8# (narrow8Word# (x# `minusWord#` y#)) + (W8# x#) * (W8# y#) = W8# (narrow8Word# (x# `timesWord#` y#)) + negate (W8# x#) = W8# (narrow8Word# (int2Word# (negateInt# (word2Int# x#)))) abs x = x signum 0 = 0 signum _ = 1 - fromInteger (S# i#) = W8# (wordToWord8# (int2Word# i#)) - fromInteger (J# s# d#) = W8# (wordToWord8# (integer2Word# s# d#)) + fromInteger (S# i#) = W8# (narrow8Word# (int2Word# i#)) + fromInteger (J# s# d#) = W8# (narrow8Word# (integer2Word# s# d#)) instance Real Word8 where toRational x = toInteger x % 1 @@ -244,11 +242,10 @@ instance Bounded Word8 where maxBound = 0xFF instance Ix Word8 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Word8" - inRange (m,n) i = m <= i && i <= n + range (m,n) = [m..n] + unsafeIndex b@(m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 instance Read Word8 where readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] @@ -259,10 +256,12 @@ instance Bits Word8 where (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#) complement (W8# x#) = W8# (x# `xor#` mb#) where W8# mb# = maxBound (W8# x#) `shift` (I# i#) - | i# >=# 0# = W8# (wordToWord8# (x# `shiftL#` i#)) + | i# >=# 0# = W8# (narrow8Word# (x# `shiftL#` i#)) | otherwise = W8# (x# `shiftRL#` negateInt# i#) - (W8# x#) `rotate` (I# i#) = W8# (wordToWord8# ((x# `shiftL#` i'#) `or#` - (x# `shiftRL#` (8# -# i'#)))) + (W8# x#) `rotate` (I# i#) + | i'# ==# 0# = W8# x# + | otherwise = W8# (narrow8Word# ((x# `shiftL#` i'#) `or#` + (x# `shiftRL#` (8# -# i'#)))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) bitSize _ = 8 @@ -271,7 +270,7 @@ instance Bits Word8 where {-# RULES "fromIntegral/Word8->Word8" fromIntegral = id :: Word8 -> Word8 "fromIntegral/Word8->Integer" fromIntegral = toInteger :: Word8 -> Integer -"fromIntegral/a->Word8" fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (wordToWord8# x#) +"fromIntegral/a->Word8" fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (narrow8Word# x#) "fromIntegral/Word8->a" fromIntegral = \(W8# x#) -> fromIntegral (W# x#) #-} @@ -291,15 +290,15 @@ instance Show Word16 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Word16 where - (W16# x#) + (W16# y#) = W16# (wordToWord16# (x# `plusWord#` y#)) - (W16# x#) - (W16# y#) = W16# (wordToWord16# (x# `minusWord#` y#)) - (W16# x#) * (W16# y#) = W16# (wordToWord16# (x# `timesWord#` y#)) - negate (W16# x#) = W16# (wordToWord16# (int2Word# (negateInt# (word2Int# x#)))) + (W16# x#) + (W16# y#) = W16# (narrow16Word# (x# `plusWord#` y#)) + (W16# x#) - (W16# y#) = W16# (narrow16Word# (x# `minusWord#` y#)) + (W16# x#) * (W16# y#) = W16# (narrow16Word# (x# `timesWord#` y#)) + negate (W16# x#) = W16# (narrow16Word# (int2Word# (negateInt# (word2Int# x#)))) abs x = x signum 0 = 0 signum _ = 1 - fromInteger (S# i#) = W16# (wordToWord16# (int2Word# i#)) - fromInteger (J# s# d#) = W16# (wordToWord16# (integer2Word# s# d#)) + fromInteger (S# i#) = W16# (narrow16Word# (int2Word# i#)) + fromInteger (J# s# d#) = W16# (narrow16Word# (integer2Word# s# d#)) instance Real Word16 where toRational x = toInteger x % 1 @@ -345,11 +344,10 @@ instance Bounded Word16 where maxBound = 0xFFFF instance Ix Word16 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Word16" - inRange (m,n) i = m <= i && i <= n + range (m,n) = [m..n] + unsafeIndex b@(m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 instance Read Word16 where readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] @@ -360,10 +358,12 @@ instance Bits Word16 where (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#) complement (W16# x#) = W16# (x# `xor#` mb#) where W16# mb# = maxBound (W16# x#) `shift` (I# i#) - | i# >=# 0# = W16# (wordToWord16# (x# `shiftL#` i#)) + | i# >=# 0# = W16# (narrow16Word# (x# `shiftL#` i#)) | otherwise = W16# (x# `shiftRL#` negateInt# i#) - (W16# x#) `rotate` (I# i#) = W16# (wordToWord16# ((x# `shiftL#` i'#) `or#` - (x# `shiftRL#` (16# -# i'#)))) + (W16# x#) `rotate` (I# i#) + | i'# ==# 0# = W16# x# + | otherwise = W16# (narrow16Word# ((x# `shiftL#` i'#) `or#` + (x# `shiftRL#` (16# -# i'#)))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) bitSize _ = 16 @@ -373,7 +373,7 @@ instance Bits Word16 where "fromIntegral/Word8->Word16" fromIntegral = \(W8# x#) -> W16# x# "fromIntegral/Word16->Word16" fromIntegral = id :: Word16 -> Word16 "fromIntegral/Word16->Integer" fromIntegral = toInteger :: Word16 -> Integer -"fromIntegral/a->Word16" fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (wordToWord16# x#) +"fromIntegral/a->Word16" fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (narrow16Word# x#) "fromIntegral/Word16->a" fromIntegral = \(W16# x#) -> fromIntegral (W# x#) #-} @@ -381,37 +381,142 @@ instance Bits Word16 where -- type Word32 ------------------------------------------------------------------------ +#if WORD_SIZE_IN_BITS < 32 + +data Word32 = W32# Word32# + +instance Eq Word32 where + (W32# x#) == (W32# y#) = x# `eqWord32#` y# + (W32# x#) /= (W32# y#) = x# `neWord32#` y# + +instance Ord Word32 where + (W32# x#) < (W32# y#) = x# `ltWord32#` y# + (W32# x#) <= (W32# y#) = x# `leWord32#` y# + (W32# x#) > (W32# y#) = x# `gtWord32#` y# + (W32# x#) >= (W32# y#) = x# `geWord32#` y# + +instance Num Word32 where + (W32# x#) + (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `plusInt32#` word32ToInt32# y#)) + (W32# x#) - (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `minusInt32#` word32ToInt32# y#)) + (W32# x#) * (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `timesInt32#` word32ToInt32# y#)) + negate (W32# x#) = W32# (int32ToWord32# (negateInt32# (word32ToInt32# x#))) + abs x = x + signum 0 = 0 + signum _ = 1 + fromInteger (S# i#) = W32# (int32ToWord32# (intToInt32# i#)) + fromInteger (J# s# d#) = W32# (integerToWord32# s# d#) + +instance Enum Word32 where + succ x + | x /= maxBound = x + 1 + | otherwise = succError "Word32" + pred x + | x /= minBound = x - 1 + | otherwise = predError "Word32" + toEnum i@(I# i#) + | i >= 0 = W32# (wordToWord32# (int2Word# i#)) + | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32) + fromEnum x@(W32# x#) + | x <= fromIntegral (maxBound::Int) + = I# (word2Int# (word32ToWord# x#)) + | otherwise = fromEnumError "Word32" x + enumFrom = integralEnumFrom + enumFromThen = integralEnumFromThen + enumFromTo = integralEnumFromTo + enumFromThenTo = integralEnumFromThenTo + +instance Integral Word32 where + quot x@(W32# x#) y@(W32# y#) + | y /= 0 = W32# (x# `quotWord32#` y#) + | otherwise = divZeroError "quot{Word32}" x + rem x@(W32# x#) y@(W32# y#) + | y /= 0 = W32# (x# `remWord32#` y#) + | otherwise = divZeroError "rem{Word32}" x + div x@(W32# x#) y@(W32# y#) + | y /= 0 = W32# (x# `quotWord32#` y#) + | otherwise = divZeroError "div{Word32}" x + mod x@(W32# x#) y@(W32# y#) + | y /= 0 = W32# (x# `remWord32#` y#) + | otherwise = divZeroError "mod{Word32}" x + quotRem x@(W32# x#) y@(W32# y#) + | y /= 0 = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#)) + | otherwise = divZeroError "quotRem{Word32}" x + divMod x@(W32# x#) y@(W32# y#) + | y /= 0 = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#)) + | otherwise = divZeroError "quotRem{Word32}" x + toInteger x@(W32# x#) + | x <= fromIntegral (maxBound::Int) = S# (word2Int# (word32ToWord# x#)) + | otherwise = case word32ToInteger# x# of (# s, d #) -> J# s d + +instance Bits Word32 where + (W32# x#) .&. (W32# y#) = W32# (x# `and32#` y#) + (W32# x#) .|. (W32# y#) = W32# (x# `or32#` y#) + (W32# x#) `xor` (W32# y#) = W32# (x# `xor32#` y#) + complement (W32# x#) = W32# (not32# x#) + (W32# x#) `shift` (I# i#) + | i# >=# 0# = W32# (x# `shiftL32#` i#) + | otherwise = W32# (x# `shiftRL32#` negateInt# i#) + (W32# x#) `rotate` (I# i#) + | i'# ==# 0# = W32# x# + | otherwise = W32# ((x# `shiftL32#` i'#) `or32#` + (x# `shiftRL32#` (32# -# i'#))) + where + i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) + bitSize _ = 32 + isSigned _ = False + +foreign import "stg_eqWord32" unsafe eqWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_neWord32" unsafe neWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_ltWord32" unsafe ltWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_leWord32" unsafe leWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_gtWord32" unsafe gtWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_geWord32" unsafe geWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_int32ToWord32" unsafe int32ToWord32# :: Int32# -> Word32# +foreign import "stg_word32ToInt32" unsafe word32ToInt32# :: Word32# -> Int32# +foreign import "stg_intToInt32" unsafe intToInt32# :: Int# -> Int32# +foreign import "stg_wordToWord32" unsafe wordToWord32# :: Word# -> Word32# +foreign import "stg_word32ToWord" unsafe word32ToWord# :: Word32# -> Word# +foreign import "stg_plusInt32" unsafe plusInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_minusInt32" unsafe minusInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_timesInt32" unsafe timesInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_negateInt32" unsafe negateInt32# :: Int32# -> Int32# +foreign import "stg_quotWord32" unsafe quotWord32# :: Word32# -> Word32# -> Word32# +foreign import "stg_remWord32" unsafe remWord32# :: Word32# -> Word32# -> Word32# +foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# -> Word32# +foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32# +foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32# +foreign import "stg_not32" unsafe not32# :: Word32# -> Word32# +foreign import "stg_shiftL32" unsafe shiftL32# :: Word32# -> Int# -> Word32# +foreign import "stg_shiftRL32" unsafe shiftRL32# :: Word32# -> Int# -> Word32# + +{-# RULES +"fromIntegral/Int->Word32" fromIntegral = \(I# x#) -> W32# (int32ToWord32# (intToInt32# x#)) +"fromIntegral/Word->Word32" fromIntegral = \(W# x#) -> W32# (wordToWord32# x#) +"fromIntegral/Word32->Int" fromIntegral = \(W32# x#) -> I# (word2Int# (word32ToWord# x#)) +"fromIntegral/Word32->Word" fromIntegral = \(W32# x#) -> W# (word32ToWord# x#) +"fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32 + #-} + +#else + -- Word32 is represented in the same way as Word. -#if WORD_SIZE_IN_BYTES == 8 +#if WORD_SIZE_IN_BITS > 32 -- Operations may assume and must ensure that it holds only values -- from its logical range. #endif data Word32 = W32# Word# deriving (Eq, Ord) -instance CCallable Word32 -instance CReturnable Word32 - -instance Show Word32 where -#if WORD_SIZE_IN_BYTES == 4 - showsPrec p x = showsPrec p (toInteger x) -#else - showsPrec p x = showsPrec p (fromIntegral x :: Int) -#endif - instance Num Word32 where - (W32# x#) + (W32# y#) = W32# (wordToWord32# (x# `plusWord#` y#)) - (W32# x#) - (W32# y#) = W32# (wordToWord32# (x# `minusWord#` y#)) - (W32# x#) * (W32# y#) = W32# (wordToWord32# (x# `timesWord#` y#)) - negate (W32# x#) = W32# (wordToWord32# (int2Word# (negateInt# (word2Int# x#)))) + (W32# x#) + (W32# y#) = W32# (narrow32Word# (x# `plusWord#` y#)) + (W32# x#) - (W32# y#) = W32# (narrow32Word# (x# `minusWord#` y#)) + (W32# x#) * (W32# y#) = W32# (narrow32Word# (x# `timesWord#` y#)) + negate (W32# x#) = W32# (narrow32Word# (int2Word# (negateInt# (word2Int# x#)))) abs x = x signum 0 = 0 signum _ = 1 - fromInteger (S# i#) = W32# (wordToWord32# (int2Word# i#)) - fromInteger (J# s# d#) = W32# (wordToWord32# (integer2Word# s# d#)) - -instance Real Word32 where - toRational x = toInteger x % 1 + fromInteger (S# i#) = W32# (narrow32Word# (int2Word# i#)) + fromInteger (J# s# d#) = W32# (narrow32Word# (integer2Word# s# d#)) instance Enum Word32 where succ x @@ -422,12 +527,12 @@ instance Enum Word32 where | otherwise = predError "Word32" toEnum i@(I# i#) | i >= 0 -#if WORD_SIZE_IN_BYTES == 8 +#if WORD_SIZE_IN_BITS > 32 && i <= fromIntegral (maxBound::Word32) #endif = W32# (int2Word# i#) | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32) -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS == 32 fromEnum x@(W32# x#) | x <= fromIntegral (maxBound::Int) = I# (word2Int# x#) @@ -462,7 +567,7 @@ instance Integral Word32 where | y /= 0 = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#)) | otherwise = divZeroError "quotRem{Word32}" x toInteger (W32# x#) -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS == 32 | i# >=# 0# = S# i# | otherwise = case word2Integer# x# of (# s, d #) -> J# s d where @@ -471,34 +576,18 @@ instance Integral Word32 where = S# (word2Int# x#) #endif -instance Bounded Word32 where - minBound = 0 - maxBound = 0xFFFFFFFF - -instance Ix Word32 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Word32" - inRange (m,n) i = m <= i && i <= n - -instance Read Word32 where -#if WORD_SIZE_IN_BYTES == 4 - readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] -#else - readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] -#endif - instance Bits Word32 where (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#) (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#) (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#) complement (W32# x#) = W32# (x# `xor#` mb#) where W32# mb# = maxBound (W32# x#) `shift` (I# i#) - | i# >=# 0# = W32# (wordToWord32# (x# `shiftL#` i#)) + | i# >=# 0# = W32# (narrow32Word# (x# `shiftL#` i#)) | otherwise = W32# (x# `shiftRL#` negateInt# i#) - (W32# x#) `rotate` (I# i#) = W32# (wordToWord32# ((x# `shiftL#` i'#) `or#` - (x# `shiftRL#` (32# -# i'#)))) + (W32# x#) `rotate` (I# i#) + | i'# ==# 0# = W32# x# + | otherwise = W32# (narrow32Word# ((x# `shiftL#` i'#) `or#` + (x# `shiftRL#` (32# -# i'#)))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) bitSize _ = 32 @@ -509,15 +598,48 @@ instance Bits Word32 where "fromIntegral/Word16->Word32" fromIntegral = \(W16# x#) -> W32# x# "fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32 "fromIntegral/Word32->Integer" fromIntegral = toInteger :: Word32 -> Integer -"fromIntegral/a->Word32" fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (wordToWord32# x#) +"fromIntegral/a->Word32" fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (narrow32Word# x#) "fromIntegral/Word32->a" fromIntegral = \(W32# x#) -> fromIntegral (W# x#) #-} +#endif + +instance CCallable Word32 +instance CReturnable Word32 + +instance Show Word32 where +#if WORD_SIZE_IN_BITS < 33 + showsPrec p x = showsPrec p (toInteger x) +#else + showsPrec p x = showsPrec p (fromIntegral x :: Int) +#endif + + +instance Real Word32 where + toRational x = toInteger x % 1 + +instance Bounded Word32 where + minBound = 0 + maxBound = 0xFFFFFFFF + +instance Ix Word32 where + range (m,n) = [m..n] + unsafeIndex b@(m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + +instance Read Word32 where +#if WORD_SIZE_IN_BITS < 33 + readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] +#else + readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] +#endif + ------------------------------------------------------------------------ -- type Word64 ------------------------------------------------------------------------ -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS < 64 data Word64 = W64# Word64# @@ -592,8 +714,10 @@ instance Bits Word64 where (W64# x#) `shift` (I# i#) | i# >=# 0# = W64# (x# `shiftL64#` i#) | otherwise = W64# (x# `shiftRL64#` negateInt# i#) - (W64# x#) `rotate` (I# i#) = W64# ((x# `shiftL64#` i'#) `or64#` - (x# `shiftRL64#` (64# -# i'#))) + (W64# x#) `rotate` (I# i#) + | i'# ==# 0# = W64# x# + | otherwise = W64# ((x# `shiftL64#` i'#) `or64#` + (x# `shiftRL64#` (64# -# i'#))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) bitSize _ = 64 @@ -607,13 +731,13 @@ foreign import "stg_gtWord64" unsafe gtWord64# :: Word64# -> Word64# - foreign import "stg_geWord64" unsafe geWord64# :: Word64# -> Word64# -> Bool foreign import "stg_int64ToWord64" unsafe int64ToWord64# :: Int64# -> Word64# foreign import "stg_word64ToInt64" unsafe word64ToInt64# :: Word64# -> Int64# +foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64# +foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64# +foreign import "stg_word64ToWord" unsafe word64ToWord# :: Word64# -> Word# foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64# foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64# foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64# foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64# -foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64# -foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64# -foreign import "stg_word64ToWord" unsafe word64ToWord# :: Word64# -> Word# foreign import "stg_quotWord64" unsafe quotWord64# :: Word64# -> Word64# -> Word64# foreign import "stg_remWord64" unsafe remWord64# :: Word64# -> Word64# -> Word64# foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64# @@ -623,6 +747,9 @@ foreign import "stg_not64" unsafe not64# :: Word64# -> Word64# foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64# foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64# +foreign import "stg_integerToWord64" unsafe integerToWord64# :: Int# -> ByteArray# -> Word64# + + {-# RULES "fromIntegral/Int->Word64" fromIntegral = \(I# x#) -> W64# (int64ToWord64# (intToInt64# x#)) "fromIntegral/Word->Word64" fromIntegral = \(W# x#) -> W64# (wordToWord64# x#) @@ -633,6 +760,10 @@ foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> W #else +-- Word64 is represented in the same way as Word. +-- Operations may assume and must ensure that it holds only values +-- from its logical range. + data Word64 = W64# Word# deriving (Eq, Ord) instance Num Word64 where @@ -698,8 +829,10 @@ instance Bits Word64 where (W64# x#) `shift` (I# i#) | i# >=# 0# = W64# (x# `shiftL#` i#) | otherwise = W64# (x# `shiftRL#` negateInt# i#) - (W64# x#) `rotate` (I# i#) = W64# ((x# `shiftL#` i'#) `or#` - (x# `shiftRL#` (64# -# i'#))) + (W64# x#) `rotate` (I# i#) + | i'# ==# 0# = W64# x# + | otherwise = W64# ((x# `shiftL#` i'#) `or#` + (x# `shiftRL#` (64# -# i'#))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) bitSize _ = 64 @@ -726,11 +859,10 @@ instance Bounded Word64 where maxBound = 0xFFFFFFFFFFFFFFFF instance Ix Word64 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Word64" - inRange (m,n) i = m <= i && i <= n + range (m,n) = [m..n] + unsafeIndex b@(m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 instance Read Word64 where readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] diff --git a/Makefile b/Makefile index 6c8f6bb..1240ea8 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.6 2001/09/13 11:35:09 simonmar Exp $ +# $Id: Makefile,v 1.7 2001/12/21 15:07:20 simonmar Exp $ TOP=.. include $(TOP)/mk/boilerplate.mk @@ -37,13 +37,34 @@ ALL_DIRS = \ PKG=core -# dependencies between .hsc files -GHC/IO.hs : GHC/Handle.hs +# ----------------------------------------------------------------------------- +# PrimOpWrappers + +GHC/PrimopWrappers.hs: $(GHC_COMPILER_DIR)/prelude/primops.txt + rm -f $@ + $(GHC_GENPRIMOP) --make-haskell-wrappers < $< > $@ + +boot :: GHC/PrimOpWrappers.hs + +CLEAN_FILES += GHC/PrimopWrappers.hs + +# ----------------------------------------------------------------------------- +# GHC/Prim.hi-boot + +#GHC/Prim.$(way_)hi : GHC/Prim.hi-boot +# cp $< $@ +# +#ALL_PRIMS = GHC/Prim.hi $(foreach way, $(WAYS), GHC/Prim.$(way)_hi) +# +#lib : $(ALL_PRIMS) +# +#boot :: $(ALL_PRIMS) +# +#CLEAN_FILES += $(ALL_PRIMS) -GHC/Prim.$(way_)hi : GHC/Prim.hi-boot - cp $< $@ +lib : GHC/Prim.hi-boot -lib : GHC/Prim.$(way_)hi +SRC_CPP_OPTS += -I$(GHC_INCLUDE_DIR) -traditional # ----------------------------------------------------------------------------- diff --git a/System/CPUTime.hsc b/System/CPUTime.hsc index e868757..de4186a 100644 --- a/System/CPUTime.hsc +++ b/System/CPUTime.hsc @@ -8,7 +8,7 @@ -- Stability : provisional -- Portability : portable -- --- $Id: CPUTime.hsc,v 1.4 2001/08/17 12:50:34 simonmar Exp $ +-- $Id: CPUTime.hsc,v 1.5 2001/12/21 15:07:26 simonmar Exp $ -- -- The standard CPUTime library. -- @@ -17,7 +17,7 @@ module System.CPUTime ( getCPUTime, -- :: IO Integer - cpuTimePrecision -- :: Integer + cpuTimePrecision -- :: Integer ) where import Prelude @@ -55,10 +55,10 @@ getCPUTime = do let ru_utime = (#ptr struct rusage, ru_utime) p_rusage let ru_stime = (#ptr struct rusage, ru_stime) p_rusage - u_sec <- (#peek struct timeval,tv_sec) ru_utime :: IO CLong - u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CLong - s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CLong - s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CLong + u_sec <- (#peek struct timeval,tv_sec) ru_utime :: IO CTime + u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CTime + s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CTime + s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CTime return ((fromIntegral u_sec * 1000000 + fromIntegral u_usec + fromIntegral s_sec * 1000000 + fromIntegral s_usec) diff --git a/System/Environment.hs b/System/Environment.hs index c0fe1f9..6b7c570 100644 --- a/System/Environment.hs +++ b/System/Environment.hs @@ -8,7 +8,7 @@ -- Stability : provisional -- Portability : portable -- --- $Id: Environment.hs,v 1.2 2001/08/17 12:50:34 simonmar Exp $ +-- $Id: Environment.hs,v 1.3 2001/12/21 15:07:26 simonmar Exp $ -- -- Miscellaneous information about the system environment. -- @@ -41,12 +41,13 @@ getArgs = alloca $ \ p_argc -> alloca $ \ p_argv -> do getProgArgv p_argc p_argv - p <- peek p_argc + p <- fromIntegral `liftM` peek p_argc argv <- peek p_argv peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString + - -foreign import "getProgArgv" getProgArgv :: Ptr Int -> Ptr (Ptr CString) -> IO () +foreign import "getProgArgv" unsafe + getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () -- Computation `getProgName' returns the name of the program -- as it was invoked. @@ -62,13 +63,23 @@ getProgName = unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] unpackProgName argv = do s <- peekElemOff argv 0 >>= peekCString - return (de_slash "" s) + return (basename s) where - -- re-start accumulating at every '/' - de_slash :: String -> String -> String - de_slash acc [] = reverse acc - de_slash _acc ('/':xs) = de_slash [] xs - de_slash acc (x:xs) = de_slash (x:acc) xs + basename :: String -> String + basename f = go f f + where + go acc [] = acc + go acc (x:xs) + | isPathSeparator x = go xs xs + | otherwise = go acc xs + + isPathSeparator :: Char -> Bool + isPathSeparator '/' = True +#ifdef mingw32_TARGET_OS + isPathSeparator '\\' = True +#endif + isPathSeparator _ = False + -- Computation `getEnv var' returns the value -- of the environment variable {\em var}. diff --git a/System/Mem/StableName.hs b/System/Mem/StableName.hs index 0544ea9..c40704d 100644 --- a/System/Mem/StableName.hs +++ b/System/Mem/StableName.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : non-portable -- --- $Id: StableName.hs,v 1.2 2001/09/13 11:37:08 simonmar Exp $ +-- $Id: StableName.hs,v 1.3 2001/12/21 15:07:26 simonmar Exp $ -- -- Giving an object a stable (GC-invariant) name. -- @@ -25,9 +25,8 @@ import Prelude import Data.Dynamic #ifdef __GLASGOW_HASKELL__ -import GHC.Base ( Int(..) ) import GHC.IOBase ( IO(..) ) -import GHC.Prim ( StableName#, makeStableName# +import GHC.Base ( Int(..), StableName#, makeStableName# , eqStableName#, stableNameToInt# ) ----------------------------------------------------------------------------- diff --git a/System/Random.hs b/System/Random.hs index aa3ddf6..c0633aa 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -8,7 +8,7 @@ -- Stability : provisional -- Portability : portable -- --- $Id: Random.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $ +-- $Id: Random.hs,v 1.2 2001/12/21 15:07:26 simonmar Exp $ -- -- Random numbers. -- @@ -16,7 +16,7 @@ module System.Random ( - RandomGen(next, split) + RandomGen(next, split, genRange) , StdGen , mkStdGen , Random ( random, randomR, @@ -53,8 +53,12 @@ import System.Time ( getClockTime, ClockTime(..) ) #endif class RandomGen g where - next :: g -> (Int, g) - split :: g -> (g, g) + next :: g -> (Int, g) + split :: g -> (g, g) + genRange :: g -> (Int,Int) + + -- default mathod + genRange g = (minBound,maxBound) data StdGen diff --git a/System/Time.hsc b/System/Time.hsc index 45cb695..e5cf6b0 100644 --- a/System/Time.hsc +++ b/System/Time.hsc @@ -8,7 +8,7 @@ -- Stability : provisional -- Portability : portable -- --- $Id: Time.hsc,v 1.5 2001/08/17 12:50:34 simonmar Exp $ +-- $Id: Time.hsc,v 1.6 2001/12/21 15:07:26 simonmar Exp $ -- -- The standard Time library. -- @@ -205,9 +205,9 @@ noTimeDiff = TimeDiff 0 0 0 0 0 0 0 getClockTime = do allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr - sec <- (#peek struct timeval,tv_sec) p_timeval :: IO Int32 - usec <- (#peek struct timeval,tv_usec) p_timeval :: IO Int32 - return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000)) + sec <- (#peek struct timeval,tv_sec) p_timeval :: IO CTime + usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CTime + return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000)) #elif HAVE_FTIME getClockTime = do @@ -215,7 +215,7 @@ getClockTime = do ftime p_timeb sec <- (#peek struct timeb,time) p_timeb :: IO CTime msec <- (#peek struct timeb,millitm) p_timeb :: IO CUShort - return (TOD (fromIntegral sec) (fromIntegral msec * 1000{-ToDo: correct???-})) + return (TOD (fromIntegral sec) (fromIntegral msec * 1000000000)) #else /* use POSIX time() */ getClockTime = do @@ -470,7 +470,7 @@ toClockTime (CalendarTime year mon mday hour min sec psec -- gmtoff <- gmtoff p_tm let res = fromIntegral t - tz + fromIntegral gmtoff - return (TOD (fromIntegral res) 0) + return (TOD (fromIntegral res) psec) -- ----------------------------------------------------------------------------- -- Converting time values to strings. diff --git a/cbits/PrelIOUtils.c b/cbits/PrelIOUtils.c new file mode 100644 index 0000000..44065b8 --- /dev/null +++ b/cbits/PrelIOUtils.c @@ -0,0 +1,9 @@ +/* + * (c) The University of Glasgow 2001 + * + * static versions of the inline functions in HsCore.h + */ + +#define INLINE +#include "HsCore.h" + diff --git a/cbits/dirUtils.c b/cbits/dirUtils.c new file mode 100644 index 0000000..a224004 --- /dev/null +++ b/cbits/dirUtils.c @@ -0,0 +1,75 @@ +/* + * (c) The GRASP/AQUA Project, Glasgow University, 1994- + * + * Directory Runtime Support + */ +#include "dirUtils.h" + +#if defined(mingw32_TARGET_OS) +#include +#endif + +#ifdef HAVE_STDLIB_H +# include +#endif +#ifdef HAVE_STDDEF_H +# include +#endif +#ifdef HAVE_ERRNO_H +# include +#endif + +HsInt +prel_mkdir(HsAddr pathName, HsInt mode) +{ +#if defined(mingw32_TARGET_OS) + return mkdir(pathName); +#else + return mkdir(pathName,mode); +#endif +} + +HsInt +prel_lstat(HsAddr fname, HsAddr st) +{ +#ifdef HAVE_LSTAT + return lstat((const char*)fname, (struct stat*)st); +#else + return stat((const char*)fname, (struct stat*)st); +#endif +} + +HsInt prel_s_ISDIR(mode_t m) {return S_ISDIR(m);} +HsInt prel_s_ISREG(mode_t m) {return S_ISREG(m);} + +HsInt prel_sz_stat() { return sizeof(struct stat); } +HsInt prel_path_max() { return PATH_MAX; } +mode_t prel_R_OK() { return R_OK; } +mode_t prel_W_OK() { return W_OK; } +mode_t prel_X_OK() { return X_OK; } + +mode_t prel_S_IRUSR() { return S_IRUSR; } +mode_t prel_S_IWUSR() { return S_IWUSR; } +mode_t prel_S_IXUSR() { return S_IXUSR; } + +time_t prel_st_mtime(struct stat* st) { return st->st_mtime; } +mode_t prel_st_mode(struct stat* st) { return st->st_mode; } + +HsAddr prel_d_name(struct dirent* d) +{ +#ifndef mingw32_TARGET_OS + return (HsAddr)(&d->d_name); +#else + return (HsAddr)(d->d_name); +#endif +} + +HsInt prel_end_of_dir() +{ +#ifndef mingw32_TARGET_OS + return 0; +#else + return ENOENT; +#endif +} + diff --git a/cbits/errno.c b/cbits/errno.c index b8e7907..d095ee2 100644 --- a/cbits/errno.c +++ b/cbits/errno.c @@ -1,7 +1,7 @@ /* * (c) The University of Glasgow, 2000-2001 * - * $Id: errno.c,v 1.2 2001/07/31 11:51:09 simonmar Exp $ + * $Id: errno.c,v 1.3 2001/12/21 15:07:26 simonmar Exp $ * * GHC Error Number Conversion */ @@ -14,3 +14,597 @@ int *ghcErrno(void) { return &errno; } + + +/* Wrappers for the individual error codes - boring */ +#define ErrCode(x) HsInt prel_error_##x() { return x; } +#define ErrCode2(x,y) HsInt prel_error_##x() { return y; } + +#ifdef E2BIG +ErrCode(E2BIG) +#else +ErrCode2(E2BIG,-1) +#endif + +#ifdef EACCES +ErrCode(EACCES) +#else +ErrCode2(EACCES,-1) +#endif + +#ifdef EADDRINUSE +ErrCode(EADDRINUSE) +#else +ErrCode2(EADDRINUSE,-1) +#endif + +#ifdef EADDRNOTAVAIL +ErrCode(EADDRNOTAVAIL) +#else +ErrCode2(EADDRNOTAVAIL,-1) +#endif + +#ifdef EADV +ErrCode(EADV) +#else +ErrCode2(EADV,-1) +#endif + +#ifdef EAFNOSUPPORT +ErrCode(EAFNOSUPPORT) +#else +ErrCode2(EAFNOSUPPORT,-1) +#endif + +#ifdef EAGAIN +ErrCode(EAGAIN) +#else +ErrCode2(EAGAIN,-1) +#endif + +#ifdef EALREADY +ErrCode(EALREADY) +#else +ErrCode2(EALREADY,-1) +#endif + +#ifdef EBADF +ErrCode(EBADF) +#else +ErrCode2(EBADF,-1) +#endif + +#ifdef EBADMSG +ErrCode(EBADMSG) +#else +ErrCode2(EBADMSG,-1) +#endif + +#ifdef EBADRPC +ErrCode(EBADRPC) +#else +ErrCode2(EBADRPC,-1) +#endif + +#ifdef EBUSY +ErrCode(EBUSY) +#else +ErrCode2(EBUSY,-1) +#endif + +#ifdef ECHILD +ErrCode(ECHILD) +#else +ErrCode2(ECHILD,-1) +#endif + +#ifdef ECOMM +ErrCode(ECOMM) +#else +ErrCode2(ECOMM,-1) +#endif + +#ifdef ECONNABORTED +ErrCode(ECONNABORTED) +#else +ErrCode2(ECONNABORTED,-1) +#endif + +#ifdef ECONNREFUSED +ErrCode(ECONNREFUSED) +#else +ErrCode2(ECONNREFUSED,-1) +#endif + +#ifdef ECONNRESET +ErrCode(ECONNRESET) +#else +ErrCode2(ECONNRESET,-1) +#endif + +#ifdef EDEADLK +ErrCode(EDEADLK) +#else +ErrCode2(EDEADLK,-1) +#endif + +#ifdef EDESTADDRREQ +ErrCode(EDESTADDRREQ) +#else +ErrCode2(EDESTADDRREQ,-1) +#endif + +#ifdef EDIRTY +ErrCode(EDIRTY) +#else +ErrCode2(EDIRTY,-1) +#endif + +#ifdef EDOM +ErrCode(EDOM) +#else +ErrCode2(EDOM,-1) +#endif + +#ifdef EDQUOT +ErrCode(EDQUOT) +#else +ErrCode2(EDQUOT,-1) +#endif + +#ifdef EEXIST +ErrCode(EEXIST) +#else +ErrCode2(EEXIST,-1) +#endif + +#ifdef EFAULT +ErrCode(EFAULT) +#else +ErrCode2(EFAULT,-1) +#endif + +#ifdef EFBIG +ErrCode(EFBIG) +#else +ErrCode2(EFBIG,-1) +#endif + +#ifdef EFTYPE +ErrCode(EFTYPE) +#else +ErrCode2(EFTYPE,-1) +#endif + +#ifdef EHOSTDOWN +ErrCode(EHOSTDOWN) +#else +ErrCode2(EHOSTDOWN,-1) +#endif + +#ifdef EHOSTUNREACH +ErrCode(EHOSTUNREACH) +#else +ErrCode2(EHOSTUNREACH,-1) +#endif + +#ifdef EIDRM +ErrCode(EIDRM) +#else +ErrCode2(EIDRM,-1) +#endif + +#ifdef EILSEQ +ErrCode(EILSEQ) +#else +ErrCode2(EILSEQ,-1) +#endif + +#ifdef EINPROGRESS +ErrCode(EINPROGRESS) +#else +ErrCode2(EINPROGRESS,-1) +#endif + +#ifdef EINTR +ErrCode(EINTR) +#else +ErrCode2(EINTR,-1) +#endif + +#ifdef EINVAL +ErrCode(EINVAL) +#else +ErrCode2(EINVAL,-1) +#endif + +#ifdef EIO +ErrCode(EIO) +#else +ErrCode2(EIO,-1) +#endif + +#ifdef EISCONN +ErrCode(EISCONN) +#else +ErrCode2(EISCONN,-1) +#endif + +#ifdef EISDIR +ErrCode(EISDIR) +#else +ErrCode2(EISDIR,-1) +#endif + +#ifdef ELOOP +ErrCode(ELOOP) +#else +ErrCode2(ELOOP,-1) +#endif + +#ifdef EMFILE +ErrCode(EMFILE) +#else +ErrCode2(EMFILE,-1) +#endif + +#ifdef EMLINK +ErrCode(EMLINK) +#else +ErrCode2(EMLINK,-1) +#endif + +#ifdef EMSGSIZE +ErrCode(EMSGSIZE) +#else +ErrCode2(EMSGSIZE,-1) +#endif + +#ifdef EMULTIHOP +ErrCode(EMULTIHOP) +#else +ErrCode2(EMULTIHOP,-1) +#endif + +#ifdef ENAMETOOLONG +ErrCode(ENAMETOOLONG) +#else +ErrCode2(ENAMETOOLONG,-1) +#endif + +#ifdef ENETDOWN +ErrCode(ENETDOWN) +#else +ErrCode2(ENETDOWN,-1) +#endif + +#ifdef ENETRESET +ErrCode(ENETRESET) +#else +ErrCode2(ENETRESET,-1) +#endif + +#ifdef ENETUNREACH +ErrCode(ENETUNREACH) +#else +ErrCode2(ENETUNREACH,-1) +#endif + +#ifdef ENFILE +ErrCode(ENFILE) +#else +ErrCode2(ENFILE,-1) +#endif + +#ifdef ENOBUFS +ErrCode(ENOBUFS) +#else +ErrCode2(ENOBUFS,-1) +#endif + +#ifdef ENODATA +ErrCode(ENODATA) +#else +ErrCode2(ENODATA,-1) +#endif + +#ifdef ENODEV +ErrCode(ENODEV) +#else +ErrCode2(ENODEV,-1) +#endif + +#ifdef ENOENT +ErrCode(ENOENT) +#else +ErrCode2(ENOENT,-1) +#endif + +#ifdef ENOEXEC +ErrCode(ENOEXEC) +#else +ErrCode2(ENOEXEC,-1) +#endif + +#ifdef ENOLCK +ErrCode(ENOLCK) +#else +ErrCode2(ENOLCK,-1) +#endif + +#ifdef ENOLINK +ErrCode(ENOLINK) +#else +ErrCode2(ENOLINK,-1) +#endif + +#ifdef ENOMEM +ErrCode(ENOMEM) +#else +ErrCode2(ENOMEM,-1) +#endif + +#ifdef ENOMSG +ErrCode(ENOMSG) +#else +ErrCode2(ENOMSG,-1) +#endif + +#ifdef ENONET +ErrCode(ENONET) +#else +ErrCode2(ENONET,-1) +#endif + +#ifdef ENOPROTOOPT +ErrCode(ENOPROTOOPT) +#else +ErrCode2(ENOPROTOOPT,-1) +#endif + +#ifdef ENOSPC +ErrCode(ENOSPC) +#else +ErrCode2(ENOSPC,-1) +#endif + +#ifdef ENOSR +ErrCode(ENOSR) +#else +ErrCode2(ENOSR,-1) +#endif + +#ifdef ENOSTR +ErrCode(ENOSTR) +#else +ErrCode2(ENOSTR,-1) +#endif + +#ifdef ENOSYS +ErrCode(ENOSYS) +#else +ErrCode2(ENOSYS,-1) +#endif + +#ifdef ENOTBLK +ErrCode(ENOTBLK) +#else +ErrCode2(ENOTBLK,-1) +#endif + +#ifdef ENOTCONN +ErrCode(ENOTCONN) +#else +ErrCode2(ENOTCONN,-1) +#endif + +#ifdef ENOTDIR +ErrCode(ENOTDIR) +#else +ErrCode2(ENOTDIR,-1) +#endif + +#ifdef ENOTEMPTY +ErrCode(ENOTEMPTY) +#else +ErrCode2(ENOTEMPTY,-1) +#endif + +#ifdef ENOTSOCK +ErrCode(ENOTSOCK) +#else +ErrCode2(ENOTSOCK,-1) +#endif + +#ifdef ENOTTY +ErrCode(ENOTTY) +#else +ErrCode2(ENOTTY,-1) +#endif + +#ifdef ENXIO +ErrCode(ENXIO) +#else +ErrCode2(ENXIO,-1) +#endif + +#ifdef EOPNOTSUPP +ErrCode(EOPNOTSUPP) +#else +ErrCode2(EOPNOTSUPP,-1) +#endif + +#ifdef EPERM +ErrCode(EPERM) +#else +ErrCode2(EPERM,-1) +#endif + +#ifdef EPFNOSUPPORT +ErrCode(EPFNOSUPPORT) +#else +ErrCode2(EPFNOSUPPORT,-1) +#endif + +#ifdef EPIPE +ErrCode(EPIPE) +#else +ErrCode2(EPIPE,-1) +#endif + +#ifdef EPROCLIM +ErrCode(EPROCLIM) +#else +ErrCode2(EPROCLIM,-1) +#endif + +#ifdef EPROCUNAVAIL +ErrCode(EPROCUNAVAIL) +#else +ErrCode2(EPROCUNAVAIL,-1) +#endif + +#ifdef EPROGMISMATCH +ErrCode(EPROGMISMATCH) +#else +ErrCode2(EPROGMISMATCH,-1) +#endif + +#ifdef EPROGUNAVAIL +ErrCode(EPROGUNAVAIL) +#else +ErrCode2(EPROGUNAVAIL,-1) +#endif + +#ifdef EPROTO +ErrCode(EPROTO) +#else +ErrCode2(EPROTO,-1) +#endif + +#ifdef EPROTONOSUPPORT +ErrCode(EPROTONOSUPPORT) +#else +ErrCode2(EPROTONOSUPPORT,-1) +#endif + +#ifdef EPROTOTYPE +ErrCode(EPROTOTYPE) +#else +ErrCode2(EPROTOTYPE,-1) +#endif + +#ifdef ERANGE +ErrCode(ERANGE) +#else +ErrCode2(ERANGE,-1) +#endif + +#ifdef EREMCHG +ErrCode(EREMCHG) +#else +ErrCode2(EREMCHG,-1) +#endif + +#ifdef EREMOTE +ErrCode(EREMOTE) +#else +ErrCode2(EREMOTE,-1) +#endif + +#ifdef EROFS +ErrCode(EROFS) +#else +ErrCode2(EROFS,-1) +#endif + +#ifdef ERPCMISMATCH +ErrCode(ERPCMISMATCH) +#else +ErrCode2(ERPCMISMATCH,-1) +#endif + +#ifdef ERREMOTE +ErrCode(ERREMOTE) +#else +ErrCode2(ERREMOTE,-1) +#endif + +#ifdef ESHUTDOWN +ErrCode(ESHUTDOWN) +#else +ErrCode2(ESHUTDOWN,-1) +#endif + +#ifdef ESOCKTNOSUPPORT +ErrCode(ESOCKTNOSUPPORT) +#else +ErrCode2(ESOCKTNOSUPPORT,-1) +#endif + +#ifdef ESPIPE +ErrCode(ESPIPE) +#else +ErrCode2(ESPIPE,-1) +#endif + +#ifdef ESRCH +ErrCode(ESRCH) +#else +ErrCode2(ESRCH,-1) +#endif + +#ifdef ESRMNT +ErrCode(ESRMNT) +#else +ErrCode2(ESRMNT,-1) +#endif + +#ifdef ESTALE +ErrCode(ESTALE) +#else +ErrCode2(ESTALE,-1) +#endif + +#ifdef ETIME +ErrCode(ETIME) +#else +ErrCode2(ETIME,-1) +#endif + +#ifdef ETIMEDOUT +ErrCode(ETIMEDOUT) +#else +ErrCode2(ETIMEDOUT,-1) +#endif + +#ifdef ETOOMANYREFS +ErrCode(ETOOMANYREFS) +#else +ErrCode2(ETOOMANYREFS,-1) +#endif + +#ifdef ETXTBSY +ErrCode(ETXTBSY) +#else +ErrCode2(ETXTBSY,-1) +#endif + +#ifdef EUSERS +ErrCode(EUSERS) +#else +ErrCode2(EUSERS,-1) +#endif + +#ifdef EWOULDBLOCK +ErrCode(EWOULDBLOCK) +#else +ErrCode2(EWOULDBLOCK,-1) +#endif + +#ifdef EXDEV +ErrCode(EXDEV) +#else +ErrCode2(EXDEV,-1) +#endif + diff --git a/cbits/ilxstubs.c b/cbits/ilxstubs.c index ae60ab7..ab3f84b 100644 --- a/cbits/ilxstubs.c +++ b/cbits/ilxstubs.c @@ -1,7 +1,7 @@ /* * (c) The GHC Team 2001 * - * $Id: ilxstubs.c,v 1.1 2001/08/17 12:47:10 simonmar Exp $ + * $Id: ilxstubs.c,v 1.2 2001/12/21 15:07:26 simonmar Exp $ * * ILX stubs for external function calls */ @@ -59,8 +59,14 @@ stackOverflow(void) { } +void * +_ErrorHdrHook(void) +{ + return &ErrorHdrHook; +} + void -ErrorHdrHook (long fd) +ErrorHdrHook(long fd) { const char msg[] = "\nFail: "; write(fd, msg, sizeof(msg)-1); diff --git a/cbits/inputReady.c b/cbits/inputReady.c index 79a605a..6585de9 100644 --- a/cbits/inputReady.c +++ b/cbits/inputReady.c @@ -1,7 +1,7 @@ /* * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 * - * $Id: inputReady.c,v 1.3 2001/08/17 12:50:34 simonmar Exp $ + * $Id: inputReady.c,v 1.4 2001/12/21 15:07:26 simonmar Exp $ * * hReady Runtime Support */ @@ -16,17 +16,18 @@ * *character* from this file object without blocking?' */ int -inputReady(int fd, int msecs) +inputReady(int fd, int msecs, int isSock) { + if #ifndef mingw32_TARGET_OS + ( 1 ) { +#else + ( isSock ) { +#endif int maxfd, ready; fd_set rfd; struct timeval tv; -#endif -#ifdef mingw32_TARGET_OS - return 1; -#else FD_ZERO(&rfd); FD_SET(fd, &rfd); @@ -45,6 +46,23 @@ inputReady(int fd, int msecs) /* 1 => Input ready, 0 => not ready, -1 => error */ return (ready); - +#ifdef mingw32_TARGET_OS + } else { + DWORD rc; + HANDLE hFile = (HANDLE)_get_osfhandle(fd); + + rc = MsgWaitForMultipleObjects( 1, + &hFile, + FALSE, /* wait all */ + msecs, /*millisecs*/ + QS_ALLEVENTS); + + /* 1 => Input ready, 0 => not ready, -1 => error */ + switch (rc) { + case WAIT_TIMEOUT: return 0; + case WAIT_OBJECT_0: return 1; + default: return -1; + } + } #endif -} + }} diff --git a/cbits/longlong.c b/cbits/longlong.c index 8118afd..4e2af36 100644 --- a/cbits/longlong.c +++ b/cbits/longlong.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: longlong.c,v 1.1 2001/07/31 12:52:37 simonmar Exp $ + * $Id: longlong.c,v 1.2 2001/12/21 15:07:26 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -74,8 +74,8 @@ StgInt64 stg_iShiftRA64 (StgInt64 a, StgInt b) {return a >> b;} StgInt64 stg_iShiftRL64 (StgInt64 a, StgInt b) {return (StgInt64) ((StgWord64) a >> b);} -/* Casting between longs and longer longs: - (the primops that cast between Integers and long longs are +/* Casting between longs and longer longs. + (the primops that cast from long longs to Integers expressed as macros, since these may cause some heap allocation). */ @@ -86,4 +86,40 @@ StgWord64 stg_wordToWord64 (StgWord w) {return (StgWord64) w;} StgWord stg_word64ToWord (StgWord64 w) {return (StgWord) w;} StgInt64 stg_word64ToInt64 (StgWord64 w) {return (StgInt64) w;} +StgWord64 stg_integerToWord64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da) +{ + mp_limb_t* d; + I_ s; + StgWord64 res; + d = (mp_limb_t *)da; + s = sa; + switch (s) { + case 0: res = 0; break; + case 1: res = d[0]; break; + case -1: res = -d[0]; break; + default: + res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); + if (s < 0) res = -res; + } + return res; +} + +StgInt64 stg_integerToInt64 (StgInt sa, StgByteArray /* Really: mp_limb_t* */ da) +{ + mp_limb_t* d; + I_ s; + StgInt64 res; + d = (mp_limb_t *)da; + s = (sa); + switch (s) { + case 0: res = 0; break; + case 1: res = d[0]; break; + case -1: res = -d[0]; break; + default: + res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); + if (s < 0) res = -res; + } + return res; +} + #endif /* SUPPORT_LONG_LONGS */ diff --git a/cbits/system.c b/cbits/system.c index 805094f..6534ca8 100644 --- a/cbits/system.c +++ b/cbits/system.c @@ -1,7 +1,7 @@ /* * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 * - * $Id: system.c,v 1.3 2001/08/17 12:50:34 simonmar Exp $ + * $Id: system.c,v 1.4 2001/12/21 15:07:26 simonmar Exp $ * * system Runtime Support */ @@ -13,6 +13,7 @@ #if defined(mingw32_TARGET_OS) #include +#include #endif HsInt @@ -20,8 +21,7 @@ systemCmd(HsAddr cmd) { /* -------------------- WINDOWS VERSION --------------------- */ #if defined(mingw32_TARGET_OS) - if (system(cmd) < 0) return -1; - return 0; + return system(cmd); #else /* -------------------- UNIX VERSION --------------------- */ int pid; diff --git a/cbits/writeError.c b/cbits/writeError.c index e4f0247..2ab4ce9 100644 --- a/cbits/writeError.c +++ b/cbits/writeError.c @@ -1,7 +1,7 @@ /* * (c) The GRASP/AQUA Project, Glasgow University, 1998 * - * $Id: writeError.c,v 1.2 2001/07/31 11:51:09 simonmar Exp $ + * $Id: writeError.c,v 1.3 2001/12/21 15:07:26 simonmar Exp $ * * hPutStr Runtime Support */ @@ -20,8 +20,10 @@ implementation in one or two places.) #include "RtsUtils.h" #include "HsCore.h" +#include "PrelIOUtils.h" + void -writeErrString__ (HsAddr msg_hdr, HsAddr msg, HsInt len) +writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len) { int count = 0; char* p = (char*)msg; diff --git a/doc/libraries.sgml b/doc/libraries.sgml index 2649483..7f4b230 100644 --- a/doc/libraries.sgml +++ b/doc/libraries.sgml @@ -261,6 +261,8 @@ We first classify each node in the hierarchy according to one of the following terms: + ToDo: unpublished interfaces. + Allocated @@ -278,10 +280,14 @@ The User hierarchy is reserved for users: a user may always use the portion of the hierarchy which is formed from his/her email address as follows: - replace the @ by a ., - reverse the order of the components, capitalise the first - letter of each component, and prepend - User.. For example, + replace any .s in the + username (before the @) with + _, replace the + @ by a + ., reverse the order of + the components, capitalise the first letter of each + component, and prepend + User.. For example, simonmar@microsoft.com becomes User.Com.Microsoft.Simonmar. @@ -360,6 +366,25 @@ are never grouped by standards compliance, portability, stability, or any other property. + + There are some other considerations when choosing where to + place libraries. Where possible, choose a layout that finds a + good compromise between depth of nesting and logical grouping of + functionality; for example, although the Text + hierarchy could logically be placed as a child of + FileFormat, we choose not to because + Text is ubiquitous and we don't want to have + to type the extra component all the time. + + Also consider consistency: if a particular sub-hierarchy + provides similar functionality to another sub-hierarchy in the + tree, then preferably the structure of the two subtrees should + also be similar. For example: under + Language.Haskell we have children + Syntax, Lexer, + Parser etc., so under + Language.C we should have a similar + structure. @@ -631,10 +656,15 @@ import Text.HTML.Internals -- The non-abstract library Foreign, ToDo: what else?. + There is one further requirement: only licenses approved by + the Open Source Initiative may be used with the core libraries. + See The Open Source + Initiative for a list of approved licensees. + ToDo: include a prototype BSD license here. - + Versioning @@ -987,7 +1017,7 @@ import Text.HTML.Internals -- The non-abstract library -- Stability : experimental | provisional | stable -- Portability : portable | non-portable (reason(s)) -- --- $Id: libraries.sgml,v 1.5 2001/08/30 13:36:00 simonmar Exp $ +-- $Id: libraries.sgml,v 1.6 2001/12/21 15:07:26 simonmar Exp $ -- -- Description ----------------------------------------------------------------------------- @@ -997,7 +1027,7 @@ import Text.HTML.Internals -- The non-abstract library - $Id: libraries.sgml,v 1.5 2001/08/30 13:36:00 simonmar Exp $ + $Id: libraries.sgml,v 1.6 2001/12/21 15:07:26 simonmar Exp $ is optional, but usually included if the module is under CVS or RCS control. @@ -1393,6 +1423,7 @@ e.g. fromInteger. Numeric -> Numeric added showHex, showOct, showBin & showIntAtBase from NumExts, + (not exported yet - these aren't H98) but left out floatToDouble & doubleToFloat (realToFrac is more general). System -> System.Exit, System.Environment, System.Cmd @@ -1405,6 +1436,7 @@ e.g. fromInteger. Directory -> System.IO.Directory Ix -> Data.Ix Locale -> System.Locale + Maybe -> Data.Maybe Monad -> Data.Monad Random -> System.Random Ratio -> Data.Ratio diff --git a/include/CTypes.h b/include/CTypes.h index b2d5c3e..9827d9d 100644 --- a/include/CTypes.h +++ b/include/CTypes.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: CTypes.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $ + * $Id: CTypes.h,v 1.2 2001/12/21 15:07:26 simonmar Exp $ * * Dirty CPP hackery for CTypes/CTypesISO * @@ -162,53 +162,28 @@ instance RealFloat T where { \ #else /* __GLASGOW_HASKELL__ */ -/* On GHC, we just cast the type of each method to the underlying - * type. This means that GHC only needs to generate the dictionary - * for each instance, rather than a new function for each method (the - * simplifier currently isn't clever enough to reduce a method that - * simply deconstructs a newtype and calls the underlying method into - * an indirection to the underlying method, so that's what we're doing - * here). +/* GHC can derive any class for a newtype, so we make use of that + * here... */ +#define NUMERIC_CLASSES Eq,Ord,Num,Enum +#define INTEGRAL_CLASSES Bounded,Real,Integral,Bits +#define FLOATING_CLASSES Real,Fractional,Floating,RealFrac,RealFloat + #define NUMERIC_TYPE(T,C,S,B) \ -newtype T = T B ; \ -INSTANCE_EQ(T,B) ; \ -INSTANCE_ORD(T,B) ; \ -INSTANCE_NUM(T,B) ; \ -INSTANCE_READ(T,B) ; \ -INSTANCE_SHOW(T,B) ; \ -INSTANCE_ENUM(T,B) +newtype T = T B deriving (NUMERIC_CLASSES); \ +INSTANCE_READ(T,B); \ +INSTANCE_SHOW(T,B) #define INTEGRAL_TYPE(T,C,S,B) \ -NUMERIC_TYPE(T,C,S,B) ; \ -INSTANCE_BOUNDED(T,B) ; \ -INSTANCE_REAL(T,B) ; \ -INSTANCE_INTEGRAL(T,B) ; \ -INSTANCE_BITS(T,B) +newtype T = T B deriving (NUMERIC_CLASSES, INTEGRAL_CLASSES); \ +INSTANCE_READ(T,B); \ +INSTANCE_SHOW(T,B) #define FLOATING_TYPE(T,C,S,B) \ -NUMERIC_TYPE(T,C,S,B) ; \ -INSTANCE_REAL(T,B) ; \ -INSTANCE_FRACTIONAL(T,B) ; \ -INSTANCE_FLOATING(T,B) ; \ -INSTANCE_REALFRAC(T) ; \ -INSTANCE_REALFLOAT(T,B) - -#define INSTANCE_EQ(T,B) \ -instance Eq T where { \ - (==) = unsafeCoerce# ((==) :: B -> B -> Bool); \ - (/=) = unsafeCoerce# ((/=) :: B -> B -> Bool); } - -#define INSTANCE_ORD(T,B) \ -instance Ord T where { \ - compare = unsafeCoerce# (compare :: B -> B -> Ordering); \ - (<) = unsafeCoerce# ((<) :: B -> B -> Bool); \ - (<=) = unsafeCoerce# ((<=) :: B -> B -> Bool); \ - (>=) = unsafeCoerce# ((>=) :: B -> B -> Bool); \ - (>) = unsafeCoerce# ((>) :: B -> B -> Bool); \ - max = unsafeCoerce# (max :: B -> B -> B); \ - min = unsafeCoerce# (min :: B -> B -> B); } +newtype T = T B deriving (NUMERIC_CLASSES, FLOATING_CLASSES); \ +INSTANCE_READ(T,B); \ +INSTANCE_SHOW(T,B) #define INSTANCE_READ(T,B) \ instance Read T where { \ @@ -221,115 +196,4 @@ instance Show T where { \ show = unsafeCoerce# (show :: B -> String); \ showList = unsafeCoerce# (showList :: [B] -> ShowS); } -#define INSTANCE_NUM(T,B) \ -instance Num T where { \ - (+) = unsafeCoerce# ((+) :: B -> B -> B); \ - (-) = unsafeCoerce# ((-) :: B -> B -> B); \ - (*) = unsafeCoerce# ((*) :: B -> B -> B); \ - negate = unsafeCoerce# (negate :: B -> B); \ - abs = unsafeCoerce# (abs :: B -> B); \ - signum = unsafeCoerce# (signum :: B -> B); \ - fromInteger = unsafeCoerce# (fromInteger :: Integer -> B); } - -#define INSTANCE_BOUNDED(T,B) \ -instance Bounded T where { \ - minBound = T minBound ; \ - maxBound = T maxBound } - -#define INSTANCE_ENUM(T,B) \ -instance Enum T where { \ - succ = unsafeCoerce# (succ :: B -> B); \ - pred = unsafeCoerce# (pred :: B -> B); \ - toEnum = unsafeCoerce# (toEnum :: Int -> B); \ - fromEnum = unsafeCoerce# (fromEnum :: B -> Int); \ - enumFrom = unsafeCoerce# (enumFrom :: B -> [B]); \ - enumFromThen = unsafeCoerce# (enumFromThen :: B -> B -> [B]); \ - enumFromTo = unsafeCoerce# (enumFromTo :: B -> B -> [B]); \ - enumFromThenTo = unsafeCoerce# (enumFromThenTo :: B -> B -> B -> [B]);} - -#define INSTANCE_REAL(T,B) \ -instance Real T where { \ - toRational = unsafeCoerce# (toRational :: B -> Rational) } - -#define INSTANCE_INTEGRAL(T,B) \ -instance Integral T where { \ - quot = unsafeCoerce# (quot:: B -> B -> B); \ - rem = unsafeCoerce# (rem:: B -> B -> B); \ - div = unsafeCoerce# (div:: B -> B -> B); \ - mod = unsafeCoerce# (mod:: B -> B -> B); \ - quotRem = unsafeCoerce# (quotRem:: B -> B -> (B,B)); \ - divMod = unsafeCoerce# (divMod:: B -> B -> (B,B)); \ - toInteger = unsafeCoerce# (toInteger:: B -> Integer); } - -#define INSTANCE_BITS(T,B) \ -instance Bits T where { \ - (.&.) = unsafeCoerce# ((.&.) :: B -> B -> B); \ - (.|.) = unsafeCoerce# ((.|.) :: B -> B -> B); \ - xor = unsafeCoerce# (xor:: B -> B -> B); \ - complement = unsafeCoerce# (complement:: B -> B); \ - shift = unsafeCoerce# (shift:: B -> Int -> B); \ - rotate = unsafeCoerce# (rotate:: B -> Int -> B); \ - bit = unsafeCoerce# (bit:: Int -> B); \ - setBit = unsafeCoerce# (setBit:: B -> Int -> B); \ - clearBit = unsafeCoerce# (clearBit:: B -> Int -> B); \ - complementBit = unsafeCoerce# (complementBit:: B -> Int -> B); \ - testBit = unsafeCoerce# (testBit:: B -> Int -> Bool); \ - bitSize = unsafeCoerce# (bitSize:: B -> Int); \ - isSigned = unsafeCoerce# (isSigned:: B -> Bool); } - -#define INSTANCE_FRACTIONAL(T,B) \ -instance Fractional T where { \ - (/) = unsafeCoerce# ((/) :: B -> B -> B); \ - recip = unsafeCoerce# (recip :: B -> B); \ - fromRational = unsafeCoerce# (fromRational :: Rational -> B); } - -#define INSTANCE_FLOATING(T,B) \ -instance Floating T where { \ - pi = unsafeCoerce# (pi :: B); \ - exp = unsafeCoerce# (exp :: B -> B); \ - log = unsafeCoerce# (log :: B -> B); \ - sqrt = unsafeCoerce# (sqrt :: B -> B); \ - (**) = unsafeCoerce# ((**) :: B -> B -> B); \ - logBase = unsafeCoerce# (logBase :: B -> B -> B); \ - sin = unsafeCoerce# (sin :: B -> B); \ - cos = unsafeCoerce# (cos :: B -> B); \ - tan = unsafeCoerce# (tan :: B -> B); \ - asin = unsafeCoerce# (asin :: B -> B); \ - acos = unsafeCoerce# (acos :: B -> B); \ - atan = unsafeCoerce# (atan :: B -> B); \ - sinh = unsafeCoerce# (sinh :: B -> B); \ - cosh = unsafeCoerce# (cosh :: B -> B); \ - tanh = unsafeCoerce# (tanh :: B -> B); \ - asinh = unsafeCoerce# (asinh :: B -> B); \ - acosh = unsafeCoerce# (acosh :: B -> B); \ - atanh = unsafeCoerce# (atanh :: B -> B); } - -/* The coerce trick doesn't work for RealFrac, these methods are - * polymorphic and overloaded. - */ -#define INSTANCE_REALFRAC(T) \ -instance RealFrac T where { \ - properFraction (T x) = let (m,y) = properFraction x in (m, T y) ; \ - truncate (T x) = truncate x ; \ - round (T x) = round x ; \ - ceiling (T x) = ceiling x ; \ - floor (T x) = floor x } - -#define INSTANCE_REALFLOAT(T,B) \ -instance RealFloat T where { \ - floatRadix = unsafeCoerce# (floatRadix :: B -> Integer); \ - floatDigits = unsafeCoerce# (floatDigits :: B -> Int); \ - floatRange = unsafeCoerce# (floatRange :: B -> (Int,Int)); \ - decodeFloat = unsafeCoerce# (decodeFloat :: B -> (Integer,Int)); \ - encodeFloat = unsafeCoerce# (encodeFloat :: Integer -> Int -> B); \ - exponent = unsafeCoerce# (exponent :: B -> Int); \ - significand = unsafeCoerce# (significand :: B -> B); \ - scaleFloat = unsafeCoerce# (scaleFloat :: Int -> B -> B); \ - isNaN = unsafeCoerce# (isNaN :: B -> Bool); \ - isInfinite = unsafeCoerce# (isInfinite :: B -> Bool); \ - isDenormalized = unsafeCoerce# (isDenormalized :: B -> Bool); \ - isNegativeZero = unsafeCoerce# (isNegativeZero :: B -> Bool); \ - isIEEE = unsafeCoerce# (isIEEE :: B -> Bool); \ - atan2 = unsafeCoerce# (atan2 :: B -> B -> B); } - #endif /* __GLASGOW_HASKELL__ */ diff --git a/include/HsCore.h b/include/HsCore.h index d07e829..3a13197 100644 --- a/include/HsCore.h +++ b/include/HsCore.h @@ -1,5 +1,7 @@ /* ----------------------------------------------------------------------------- - * $Id: HsCore.h,v 1.4 2001/09/14 11:25:57 simonmar Exp $ + * $Id: HsCore.h,v 1.5 2001/12/21 15:07:26 simonmar Exp $ + * + * (c) The University of Glasgow 2001-2002 * * Definitions for package `core' which are visible in Haskell land. * @@ -63,6 +65,9 @@ #ifdef HAVE_SYS_TIMES_H #include #endif +#ifdef HAVE_WINSOCK_H +#include +#endif #if !defined(mingw32_TARGET_OS) && !defined(irix_TARGET_OS) # if defined(HAVE_SYS_RESOURCE_H) @@ -83,47 +88,136 @@ #ifdef HAVE_VFORK_H #include #endif +#include "lockFile.h" +#include "dirUtils.h" +#include "errUtils.h" +#include "PrelIOUtils.h" -extern inline int s_isreg_wrap(m) { return S_ISREG(m); } -extern inline int s_isdir_wrap(m) { return S_ISDIR(m); } -extern inline int s_isfifo_wrap(m) { return S_ISFIFO(m); } -extern inline int s_isblk_wrap(m) { return S_ISBLK(m); } -extern inline int s_ischr_wrap(m) { return S_ISCHR(m); } -#ifdef S_ISSOCK -extern inline int s_issock_wrap(m) { return S_ISSOCK(m); } +#ifdef _WIN32 +#include +#include #endif -extern inline void * -memcpy_wrap_dst_off(char *dst, int dst_off, char *src, size_t sz) -{ return memcpy(dst+dst_off, src, sz); } +/* in ghc_errno.c */ +int *ghcErrno(void); -extern inline void * -memcpy_wrap_src_off(char *dst, char *src, int src_off, size_t sz) -{ return memcpy(dst, src+src_off, sz); } +/* in system.c */ +HsInt systemCmd(HsAddr cmd); -extern inline int -read_ba_wrap(int fd, void *ptr, HsInt off, int size) -{ return read(fd, ptr + off, size); } +/* in inputReady.c */ +int inputReady(int fd, int msecs, int isSock); -extern inline int -write_wrap(int fd, void *ptr, HsInt off, int size) -{ return write(fd, ptr + off, size); } +/* ----------------------------------------------------------------------------- + INLINE functions. -extern inline int -read_wrap(int fd, void *ptr, HsInt off, int size) -{ return read(fd, ptr + off, size); } + These functions are given as inlines here for when compiling via C, + but we also generate static versions into the cbits library for + when compiling to native code. + -------------------------------------------------------------------------- */ -#include "lockFile.h" +#ifndef INLINE +#define INLINE extern inline +#endif -#include "HsFFI.h" +INLINE int __hscore_s_isreg(m) { return S_ISREG(m); } +INLINE int __hscore_s_isdir(m) { return S_ISDIR(m); } +INLINE int __hscore_s_isfifo(m) { return S_ISFIFO(m); } +INLINE int __hscore_s_isblk(m) { return S_ISBLK(m); } +INLINE int __hscore_s_ischr(m) { return S_ISCHR(m); } +#ifdef S_ISSOCK +INLINE int __hscore_s_issock(m) { return S_ISSOCK(m); } +#endif -/* in ghc_errno.c */ -int *ghcErrno(void); +INLINE void +__hscore_sigemptyset( sigset_t *set ) +{ sigemptyset(set); } -/* in system.c */ -HsInt systemCmd(HsAddr cmd); +INLINE void * +__hscore_memcpy_dst_off( char *dst, int dst_off, char *src, size_t sz ) +{ return memcpy(dst+dst_off, src, sz); } -/* in inputReady.c */ -int inputReady(int fd, int msecs); +INLINE void * +__hscore_memcpy_src_off( char *dst, char *src, int src_off, size_t sz ) +{ return memcpy(dst, src+src_off, sz); } + +INLINE HsBool +__hscore_supportsTextMode() +{ +#if defined(mingw32_TARGET_OS) + return HS_BOOL_FALSE; +#else + return HS_BOOL_TRUE; +#endif +} + +INLINE HsInt +__hscore_bufsiz() +{ + return BUFSIZ; +} + +INLINE HsInt +__hscore_seek_cur() +{ + return SEEK_CUR; +} + +INLINE HsInt +__hscore_o_binary() +{ +#ifdef HAVE_O_BINARY + return O_BINARY; +#else + return 0; +#endif +} + +INLINE HsInt +__hscore_seek_set() +{ + return SEEK_SET; +} + +INLINE HsInt +__hscore_seek_end() +{ + return SEEK_END; +} + +INLINE HsInt +__hscore_setmode( HsInt fd, HsBool toBin ) +{ +#ifdef _WIN32 + return setmode(fd,(toBin == HS_BOOL_TRUE) ? _O_BINARY : _O_TEXT); +#else + return 0; +#endif +} + +INLINE HsInt +__hscore_PrelHandle_write( HsInt fd, HsBool isSock, HsAddr ptr, + HsInt off, int sz ) +{ +#ifdef _WIN32 + if (isSock) { + return send(fd,ptr + off, sz, 0); + } +#endif + return write(fd,ptr + off, sz); +} + +INLINE HsInt +__hscore_PrelHandle_read( HsInt fd, HsBool isSock, HsAddr ptr, + HsInt off, int sz ) +{ +#ifdef _WIN32 + if (isSock) { + return recv(fd,ptr + off, sz, 0); + } +#endif + return read(fd,ptr + off, sz); + +} #endif + diff --git a/include/PackedString.h b/include/PackedString.h deleted file mode 100644 index a0fc830..0000000 --- a/include/PackedString.h +++ /dev/null @@ -1,14 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $Id: PackedString.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $ - * - * C Definitions for PackedString.hs - * - * ---------------------------------------------------------------------------*/ - -#ifndef PACKEDSTRING_H -#define PACKEDSTRING_H - -/* PackedString.c */ -extern StgInt byteArrayHasNUL__ (StgByteArray ba, StgInt len); - -#endif diff --git a/include/PrelIOUtils.h b/include/PrelIOUtils.h new file mode 100644 index 0000000..d7b982f --- /dev/null +++ b/include/PrelIOUtils.h @@ -0,0 +1,40 @@ +/* + * (c) The University of Glasgow 2001-2002 + * + * IO / Handle support. + */ +#ifndef __PRELIOUTILS_H__ +#define __PRELIOUTILS_H__ + +/* PrelIOUtils.c */ +extern HsBool prel_supportsTextMode(); +extern HsInt prel_bufsiz(); +extern HsInt prel_seek_cur(); +extern HsInt prel_seek_set(); +extern HsInt prel_seek_end(); + +extern HsInt prel_o_binary(); + +extern HsInt prel_setmode(HsInt fd, HsBool isBin); + +extern HsInt prel_PrelHandle_write(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz); +extern HsInt prel_PrelHandle_read(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz); + +extern void* prel_PrelIO_memcpy(char *dst, HsInt dst_off, const char *src, size_t sz); + +/* writeError.c */ +extern void writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len); + +extern int s_isreg_PrelPosix_wrap(int); +extern int s_isdir_PrelPosix_wrap(int); +extern int s_isfifo_PrelPosix_wrap(int); +extern int s_isblk_PrelPosix_wrap(int); +extern int s_ischr_PrelPosix_wrap(int); +#ifndef mingw32_TARGET_OS +extern int s_issock_PrelPosix_wrap(int); +extern void sigemptyset_PrelPosix_wrap(sigset_t *set); +#endif + + +#endif /* __PRELIOUTILS_H__ */ + diff --git a/include/dirUtils.h b/include/dirUtils.h new file mode 100644 index 0000000..5be0657 --- /dev/null +++ b/include/dirUtils.h @@ -0,0 +1,38 @@ +/* + * (c) The GRASP/AQUA Project, Glasgow University, 1994- + * + * Directory Runtime Support - prototypes. + */ +#ifndef __DIRUTILS_H__ +#define __DIRUTILS_H__ + +#include +#include +#include +#include +#include + +extern HsInt prel_mkdir(HsAddr pathName, HsInt mode); +extern HsInt prel_lstat(HsAddr fname, HsAddr st); + +extern HsInt prel_s_ISDIR(mode_t m); +extern HsInt prel_s_ISREG(mode_t m); + +extern HsInt prel_sz_stat(); +extern HsInt prel_path_max(); +extern mode_t prel_R_OK(); +extern mode_t prel_W_OK(); +extern mode_t prel_X_OK(); + +extern mode_t prel_S_IRUSR(); +extern mode_t prel_S_IWUSR(); +extern mode_t prel_S_IXUSR(); + +extern time_t prel_st_mtime(struct stat* st); +extern mode_t prel_st_mode(struct stat* st); + +extern HsAddr prel_d_name(struct dirent* d); + +extern HsInt prel_end_of_dir(); + +#endif /* __DIRUTILS_H__ */ diff --git a/include/errUtils.h b/include/errUtils.h new file mode 100644 index 0000000..0578e98 --- /dev/null +++ b/include/errUtils.h @@ -0,0 +1,110 @@ +/* + * (c) The University of Glasgow, 2000-2002 + * + * GHC Error Number Conversion - prototypes. + */ +#ifndef __ERRUTILS_H__ +#define __ERRUTILS_H__ + +#define ErrCodeProto(x) extern HsInt prel_error_##x() + +ErrCodeProto(E2BIG); +ErrCodeProto(EACCES); +ErrCodeProto(EADDRINUSE); +ErrCodeProto(EADDRNOTAVAIL); +ErrCodeProto(EADV); +ErrCodeProto(EAFNOSUPPORT); +ErrCodeProto(EAGAIN); +ErrCodeProto(EALREADY); +ErrCodeProto(EBADF); +ErrCodeProto(EBADMSG); +ErrCodeProto(EBADRPC); +ErrCodeProto(EBUSY); +ErrCodeProto(ECHILD); +ErrCodeProto(ECOMM); +ErrCodeProto(ECONNABORTED); +ErrCodeProto(ECONNREFUSED); +ErrCodeProto(ECONNRESET); +ErrCodeProto(EDEADLK); +ErrCodeProto(EDESTADDRREQ); +ErrCodeProto(EDIRTY); +ErrCodeProto(EDOM); +ErrCodeProto(EDQUOT); +ErrCodeProto(EEXIST); +ErrCodeProto(EFAULT); +ErrCodeProto(EFBIG); +ErrCodeProto(EFTYPE); +ErrCodeProto(EHOSTDOWN); +ErrCodeProto(EHOSTUNREACH); +ErrCodeProto(EIDRM); +ErrCodeProto(EILSEQ); +ErrCodeProto(EINPROGRESS); +ErrCodeProto(EINTR); +ErrCodeProto(EINVAL); +ErrCodeProto(EIO); +ErrCodeProto(EISCONN); +ErrCodeProto(EISDIR); +ErrCodeProto(ELOOP); +ErrCodeProto(EMFILE); +ErrCodeProto(EMLINK); +ErrCodeProto(EMSGSIZE); +ErrCodeProto(EMULTIHOP); +ErrCodeProto(ENAMETOOLONG); +ErrCodeProto(ENETDOWN); +ErrCodeProto(ENETRESET); +ErrCodeProto(ENETUNREACH); +ErrCodeProto(ENFILE); +ErrCodeProto(ENOBUFS); +ErrCodeProto(ENODATA); +ErrCodeProto(ENODEV); +ErrCodeProto(ENOENT); +ErrCodeProto(ENOEXEC); +ErrCodeProto(ENOLCK); +ErrCodeProto(ENOLINK); +ErrCodeProto(ENOMEM); +ErrCodeProto(ENOMSG); +ErrCodeProto(ENONET); +ErrCodeProto(ENOPROTOOPT); +ErrCodeProto(ENOSPC); +ErrCodeProto(ENOSR); +ErrCodeProto(ENOSTR); +ErrCodeProto(ENOSYS); +ErrCodeProto(ENOTBLK); +ErrCodeProto(ENOTCONN); +ErrCodeProto(ENOTDIR); +ErrCodeProto(ENOTEMPTY); +ErrCodeProto(ENOTSOCK); +ErrCodeProto(ENOTTY); +ErrCodeProto(ENXIO); +ErrCodeProto(EOPNOTSUPP); +ErrCodeProto(EPERM); +ErrCodeProto(EPFNOSUPPORT); +ErrCodeProto(EPIPE); +ErrCodeProto(EPROCLIM); +ErrCodeProto(EPROCUNAVAIL); +ErrCodeProto(EPROGMISMATCH); +ErrCodeProto(EPROGUNAVAIL); +ErrCodeProto(EPROTO); +ErrCodeProto(EPROTONOSUPPORT); +ErrCodeProto(EPROTOTYPE); +ErrCodeProto(ERANGE); +ErrCodeProto(EREMCHG); +ErrCodeProto(EREMOTE); +ErrCodeProto(EROFS); +ErrCodeProto(ERPCMISMATCH); +ErrCodeProto(ERREMOTE); +ErrCodeProto(ESHUTDOWN); +ErrCodeProto(ESOCKTNOSUPPORT); +ErrCodeProto(ESPIPE); +ErrCodeProto(ESRCH); +ErrCodeProto(ESRMNT); +ErrCodeProto(ESTALE); +ErrCodeProto(ETIME); +ErrCodeProto(ETIMEDOUT); +ErrCodeProto(ETOOMANYREFS); +ErrCodeProto(ETXTBSY); +ErrCodeProto(EUSERS); +ErrCodeProto(EWOULDBLOCK); +ErrCodeProto(EXDEV); + +#endif /* __ERRUTILS_H__ */ -- 1.7.10.4