-- 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.
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__
-- 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.
#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(..) )
-- 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
--
#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
-- 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.
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__
-- 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.
--
| 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
-- 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.
--
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
-- 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.
--
#endif
#ifdef __GLASGOW_HASKELL__
-import GHC.Prim ( unsafeCoerce# )
-
unsafeCoerce :: a -> b
unsafeCoerce = unsafeCoerce#
#endif
-- 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.
--
import Prelude
#ifdef __GLASGOW_HASKELL__
-import GHC.Prim ( mkWeak# )
+import GHC.Base ( mkWeak# )
import GHC.STRef
import GHC.IOBase
#if !defined(__PARALLEL_HASKELL__)
-- 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.
--
( 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
-- 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.
--
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
-- 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.
--
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
-----------------------------------------------------------------------------
--
--- Module : Debug.QuickCheck.Poly
+-- Module : Debug.QuickCheck.Utils
-- Copyright : (c) Andy Gill 2001
-- License : BSD-style (see the file libraries/core/LICENSE)
--
-- 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
-- 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
--
-- 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
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
| errno == eNFILE = ResourceExhausted
| errno == eNOBUFS = ResourceExhausted
| errno == eNODATA = NoSuchThing
- | errno == eNODEV = NoSuchThing
+ | errno == eNODEV = UnsupportedOperation
| errno == eNOENT = NoSuchThing
| errno == eNOEXEC = InvalidArgument
| errno == eNOLCK = ResourceExhausted
#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
+
-- 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
--
import GHC.Ptr
import GHC.Err
import GHC.Base
-import GHC.Prim
#endif
% -----------------------------------------------------------------------------
-% $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
%
%*********************************************************
\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<h, but the range
+is nevertheless empty. Consider
+ ((1,2),(2,1))
+Here l<h, but the second index ranges from 2..1 and
+hence is empty
%*********************************************************
%* *
inRange (m,n) i = m <= i && i <= n
+ unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
+
----------------------------------------------------------------------
instance Ix Int where
{-# INLINE range #-}
{-# INLINE inRange #-}
inRange (I# m,I# n) (I# i) = m <=# i && i <=# n
+ unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
+
----------------------------------------------------------------------
instance Ix Integer where
{-# INLINE range #-}
inRange (m,n) i = m <= i && i <= n
+ unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
----------------------------------------------------------------------
instance Ix Bool 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 Ordering where -- as derived
{-# INLINE range #-}
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 #-}
{-# 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
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
----------------------------------------------------------------------
inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
inRange (l3,u3) i3
+ unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
+
-- Default method for index
----------------------------------------------------------------------
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
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<h, but the range
--- is nevertheless empty. Consider
--- ((1,2),(2,1))
--- Here l<h, but the second index ranges from 2..1 and
--- hence is empty
+ -- Default method for index
\end{code}
%*********************************************************
% -----------------------------------------------------------------------------
-% $Id: Base.lhs,v 1.3 2001/07/03 14:13:32 simonmar Exp $
+% $Id: Base.lhs,v 1.4 2001/12/21 15:07:22 simonmar Exp $
%
% (c) The University of Glasgow, 1992-2000
%
)
where
-import GHC.Prim
+import {-# SOURCE #-} GHC.Prim
import {-# SOURCE #-} GHC.Err
infixr 9 .
foldr :: (a -> 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
"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) .
\begin{code}
map :: (a -> b) -> [a] -> [b]
+{-# NOINLINE [1] map #-}
map = mapList
-- Note eta expanded
----------------------------------------------
\begin{code}
(++) :: [a] -> [a] -> [a]
+{-# NOINLINE [1] (++) #-}
(++) = append
{-# RULES
\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@}
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
"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
\begin{code}
unpackCString# :: Addr# -> [Char]
+{-# NOINLINE [1] unpackCString# #-}
unpackCString# a = unpackCStringList# a
unpackCStringList# :: Addr# -> [Char]
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
| 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
% -----------------------------------------------------------------------------
-% $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
%
, killThread -- :: ThreadId -> IO ()
, throwTo -- :: ThreadId -> Exception -> IO ()
, par -- :: a -> b -> b
- , seq -- :: a -> b -> b
+ , pseq -- :: a -> b -> b
, yield -- :: IO ()
-- Waiting
import GHC.Base ( Int(..) )
import GHC.Exception ( Exception(..), AsyncException(..) )
-infixr 0 `par`, `seq`
+infixr 0 `par`, `pseq`
\end{code}
%************************************************************************
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
-- 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
% -----------------------------------------------------------------------------
-% $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
%
{-# 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)
-- 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
-- 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#
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
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 #-}
{-# 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
#-}
-{-# INLINE eftIntFB #-}
+{-# INLINE [0] eftIntFB #-}
eftIntFB c n x y | x ># y = n
| otherwise = go x
where
-- 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
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)
% ------------------------------------------------------------------------------
-% $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
%
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
(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 =
(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)
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)
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)
-{-# 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
--
) where
-#include "HsCore.h"
-
import Control.Monad
import Data.Bits
import Data.Maybe
-- ---------------------------------------------------------------------------
-- 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
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_
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
"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"
-- 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
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 ()
-- ---------------------------------------------------------------------------
= 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
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
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
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")
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
-- 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 }
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
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
-- 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 = "<stdin>",
- haBuffer = buf,
- haBuffers = spares
- })
+ mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
stdout :: Handle
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 = "<stdout>",
- haBuffer = buf,
- haBuffers = spares
- })
+ mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
stderr :: Handle
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 = "<stderr>",
- haBuffer = buffer,
- haBuffers = spares
- })
+ buf <- mkUnBuffer
+ mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
-- ---------------------------------------------------------------------------
-- Opening and Closing Files
| otherwise = False
binary_flags
-#ifdef HAVE_O_BINARY
- | binary = o_BINARY
-#endif
+ | binary = PrelHandle.o_BINARY
| otherwise = 0
oflags = oflags1 .|. binary_flags
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).
-- ---------------------------------------------------------------------------
-- 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
-- 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
-- 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
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_
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)
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
-- 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
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 ()
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
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.
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
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
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
-- -----------------------------------------------------------------------------
-- 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
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
+
+
-{-# 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
--
-- 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
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
-- 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
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
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
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_
-- 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.
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
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
:: 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
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,
-- 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.
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
-- ---------------------------------------------------------------------------
-- ---------------------------------------------------------------------------
-- 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 ())
-----------------------------------------------------------------------------
% ------------------------------------------------------------------------------
-% $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
%
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-#include "config.h"
module GHC.IOBase where
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.
}
-- ---------------------------------------------------------------------------
| 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
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.
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
| 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 $
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
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
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#
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]
(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#)
#-}
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
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#
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]
(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
"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#)
#-}
-- 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
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#)
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]
(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
"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#
| 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#)
(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#)
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#))
"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)
(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#)
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}
% ------------------------------------------------------------------------------
-% $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
%
-- 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
[] -> []
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.
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)
-- 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
-- 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
\begin{code}
----------------------------------------------
zip :: [a] -> [b] -> [(a,b)]
+{-# NOINLINE [1] zip #-}
zip = zipList
+{-# INLINE [0] zipFB #-}
zipFB c x y r = (x,y) `c` r
\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]
% ------------------------------------------------------------------------------
-% $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
%
{-# 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
\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.
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
\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)
{-# 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
--
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
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
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
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
---------------------------------------------------------------------------
--- 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
tryPutMVarzh
isEmptyMVarzh
+ -- Seq
+ seq -- Defined in MkId
+
-- Parallel
seqzh
parzh
remIntzh
gcdIntzh
negateIntzh
- iShiftLzh
- iShiftRAzh
- iShiftRLzh
+ uncheckedIShiftLzh
+ uncheckedIShiftRAzh
+ uncheckedIShiftRLzh
addIntCzh
subIntCzh
- mulIntCzh
+ mulIntMayOflozh
Wordzh
gtWordzh
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
ztztzhzh
decodeDoublezh
+-- Integer is implemented by foreign imports on .NET, so no primops
+
+#ifndef ILX
cmpIntegerzh
cmpIntegerIntzh
plusIntegerzh
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
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;
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} ;
1 zdfCCallableMutableByteArrayzh :: __forall s => {CCallable (MutableByteArrayzh s)} ;
1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ;
1 zdfCCallableStablePtrzh :: __forall a => {CCallable (StablePtrzh a)} ;
+
-----------------------------------------------------------------------------
--- $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
--
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)
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
instance CReturnable (FunPtr a)
\end{code}
+
% ------------------------------------------------------------------------------
-% $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
%
(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
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
% ------------------------------------------------------------------------------
-% $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
%
\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
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
% ------------------------------------------------------------------------------
-% $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
%
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
module GHC.STRef where
import GHC.ST
-import GHC.Prim
import GHC.Base
data STRef s a = STRef (MutVar# s a)
% ------------------------------------------------------------------------------
-% $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
%
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}
%*********************************************************
% -----------------------------------------------------------------------------
-% $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
%
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,
= 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 ()
= 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}
% ------------------------------------------------------------------------------
-% $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
%
module GHC.Weak where
-import GHC.Prim
import GHC.Base
import Data.Maybe
import GHC.IOBase ( IO(..), unIO )
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]
(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
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
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]
(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
{-# 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#)
#-}
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
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]
(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
"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#)
#-}
-- 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
| 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#)
| 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
= 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
"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#
(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
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#
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#)
#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
(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
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]
# -----------------------------------------------------------------------------
-# $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
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
# -----------------------------------------------------------------------------
-- 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.
--
module System.CPUTime
(
getCPUTime, -- :: IO Integer
- cpuTimePrecision -- ::Â Integer
+ cpuTimePrecision -- :: Integer
) where
import Prelude
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)
-- 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.
--
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.
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}.
-- 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.
--
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# )
-----------------------------------------------------------------------------
-- 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.
--
module System.Random
(
- RandomGen(next, split)
+ RandomGen(next, split, genRange)
, StdGen
, mkStdGen
, Random ( random, randomR,
#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
-- 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.
--
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
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
--
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.
--- /dev/null
+/*
+ * (c) The University of Glasgow 2001
+ *
+ * static versions of the inline functions in HsCore.h
+ */
+
+#define INLINE
+#include "HsCore.h"
+
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-
+ *
+ * Directory Runtime Support
+ */
+#include "dirUtils.h"
+
+#if defined(mingw32_TARGET_OS)
+#include <windows.h>
+#endif
+
+#ifdef HAVE_STDLIB_H
+# include <stdlib.h>
+#endif
+#ifdef HAVE_STDDEF_H
+# include <stddef.h>
+#endif
+#ifdef HAVE_ERRNO_H
+# include <errno.h>
+#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
+}
+
/*
* (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
*/
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
+
/*
* (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
*/
{
}
+void *
+_ErrorHdrHook(void)
+{
+ return &ErrorHdrHook;
+}
+
void
-ErrorHdrHook (long fd)
+ErrorHdrHook(long fd)
{
const char msg[] = "\nFail: ";
write(fd, msg, sizeof(msg)-1);
/*
* (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
*/
* *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);
/* 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
-}
+ }}
/* -----------------------------------------------------------------------------
- * $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
*
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).
*/
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 */
/*
* (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
*/
#if defined(mingw32_TARGET_OS)
#include <windows.h>
+#include <stdlib.h>
#endif
HsInt
{
/* -------------------- WINDOWS VERSION --------------------- */
#if defined(mingw32_TARGET_OS)
- if (system(cmd) < 0) return -1;
- return 0;
+ return system(cmd);
#else
/* -------------------- UNIX VERSION --------------------- */
int pid;
/*
* (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
*/
#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;
<para>We first classify each node in the hierarchy according to
one of the following terms:</para>
+ ToDo: unpublished interfaces.
+
<variablelist>
<varlistentry>
<term>Allocated</term>
<para>The <literal>User</literal> 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 <literal>@</literal> by a <literal>.</literal>,
- reverse the order of the components, capitalise the first
- letter of each component, and prepend
- <literal>User.</literal>. For example,
+ replace any <quote><literal>.</literal></quote>s in the
+ username (before the <literal>@</literal>) with
+ <quote><literal>_</literal></quote>, replace the
+ <quote><literal>@</literal></quote> by a
+ <quote><literal>.</literal></quote>, reverse the order of
+ the components, capitalise the first letter of each
+ component, and prepend
+ <quote><literal>User.</literal></quote>. For example,
<literal>simonmar@microsoft.com</literal> becomes
<literal>User.Com.Microsoft.Simonmar</literal>.</para>
</listitem>
are never grouped by standards compliance, portability,
stability, or any other property.</para>
</blockquote>
+
+ <para>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 <literal>Text</literal>
+ hierarchy could logically be placed as a child of
+ <literal>FileFormat</literal>, we choose not to because
+ <literal>Text</literal> is ubiquitous and we don't want to have
+ to type the extra component all the time.</para>
+
+ <para>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
+ <literal>Language.Haskell</literal> we have children
+ <literal>Syntax</literal>, <literal>Lexer</literal>,
+ <literal>Parser</literal> etc., so under
+ <literal>Language.C</literal> we should have a similar
+ structure.</para>
</sect2>
<sect2 id="module-naming-convention">
<literal>Foreign</literal>, <emphasis>ToDo: what
else?</emphasis>.</para>
+ <para>There is one further requirement: only licenses approved by
+ the Open Source Initiative may be used with the core libraries.
+ See <ulink url="http://www.opensource.org//">The Open Source
+ Initiative</ulink> for a list of approved licensees.</para>
+
<para><emphasis>ToDo: include a prototype BSD license
here</emphasis>.</para>
</sect1>
-
+
<sect1 id="versioning">
<title>Versioning</title>
<para></para>
-- Stability : experimental | provisional | stable
-- Portability : portable | non-portable (<replaceable>reason(s)</replaceable>)
--
--- $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 $
--
-- <replaceable>Description</replaceable>
-----------------------------------------------------------------------------
<variablelist>
<varlistentry>
- <term><literal>$Id: libraries.sgml,v 1.5 2001/08/30 13:36:00 simonmar Exp $</literal></term>
+ <term><literal>$Id: libraries.sgml,v 1.6 2001/12/21 15:07:26 simonmar Exp $</literal></term>
<listitem>
<para>is optional, but usually included if the module is
under CVS or RCS control.</para>
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
Directory -> System.IO.Directory
Ix -> Data.Ix
Locale -> System.Locale
+ Maybe -> Data.Maybe
Monad -> Data.Monad
Random -> System.Random
Ratio -> Data.Ratio
/* -----------------------------------------------------------------------------
- * $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
*
#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 { \
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__ */
/* -----------------------------------------------------------------------------
- * $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.
*
#ifdef HAVE_SYS_TIMES_H
#include <sys/times.h>
#endif
+#ifdef HAVE_WINSOCK_H
+#include <winsock.h>
+#endif
#if !defined(mingw32_TARGET_OS) && !defined(irix_TARGET_OS)
# if defined(HAVE_SYS_RESOURCE_H)
#ifdef HAVE_VFORK_H
#include <vfork.h>
#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 <io.h>
+#include <fcntl.h>
#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
+
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $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
--- /dev/null
+/*
+ * (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__ */
+
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-
+ *
+ * Directory Runtime Support - prototypes.
+ */
+#ifndef __DIRUTILS_H__
+#define __DIRUTILS_H__
+
+#include <sys/stat.h>
+#include <dirent.h>
+#include <limits.h>
+#include <errno.h>
+#include <unistd.h>
+
+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__ */
--- /dev/null
+/*
+ * (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__ */
projects / ghc-base.git / commitdiff