Commit efa88123 authored by simonmar's avatar simonmar
Browse files

[project @ 2001-01-11 17:25:56 by simonmar]

Re-organisation of ghc/lib/std and hslibs/lang
----------------------------------------------

In brief: move deprecated features out of ghc/lib/std and into
hslibs/lang, move new FFI libraries into ghc/lib/std and start
using them.

- foreign import may now return an unboxed type (this was
  advertised to work before, but in fact didn't).  Subsequent
  cleanups in PrelInt/PrelWord.

- Ptr is now defined in ghc/lib/std/PrelPtr.lhs.  Ptr is no
  longer a newtype of Addr, it is defined directly in terms of
  Addr#.

- PrelAddr has disappeared from ghc/lib/std, all uses of Addr in
  ghc/lib/std have been replaced with Ptr.  The definitions of
  Addr has been moved to hslibs/lang/Addr.lhs, as has
  lots of other Addr-related stuff.

- ForeignObj has been removed from ghc/lib/std, and replaced with
  ForeignPtr.  The definition of ForeignObj has been moved to
  hslibs/lang/ForeignObj.lhs.

- Most of the new FFI has been moved into ghc/lib/std in the form
  of modules PrelMarshalAlloc, PrelCString, PrelCError,
  PrelMarshalError, PrelMarshalArray, PrelMarshalUtils,
  PrelCTypes, PrelCTypesISO, and PrelStorable.  The corresponding
  modules in hslibs/lang simply re-export the contents of these
  modules.

- PrelPosixTypes defines a few POSIX types (CMode == mode_t,
  etc.)

- PrelCError changed to access errno using foreign label and peek
  (the POSIX book I have says that errno is guaranteed to be an
  extern int, so this should be OK until I get around to making
  errno thread-safe).

- Hacked the macros that generate the code for CTypes and
  CTypesISO to generate much less code
  (ghc/lib/std/cbits/CTypes.h).

- RtsAPI is now a bit more honest when it comes to building heap
  objects (it uses the correct constructors).

- the Bits class and related stuff has been moved to ghc/lib/std
  (it was simpler this way).

- Directory and System have been converted to use the new FFI.
parent e18bb2e8
......@@ -190,6 +190,7 @@ pREL_BYTEARR_Name = mkModuleName "PrelByteArr"
pREL_FOREIGN_Name = mkModuleName "PrelForeign"
pREL_STABLE_Name = mkModuleName "PrelStable"
pREL_ADDR_Name = mkModuleName "PrelAddr"
pREL_PTR_Name = mkModuleName "PrelPtr"
pREL_ERR_Name = mkModuleName "PrelErr"
pREL_REAL_Name = mkModuleName "PrelReal"
pREL_FLOAT_Name = mkModuleName "PrelFloat"
......@@ -199,9 +200,13 @@ mAIN_Name = mkModuleName "Main"
pREL_INT_Name = mkModuleName "PrelInt"
pREL_WORD_Name = mkModuleName "PrelWord"
fOREIGNOBJ_Name = mkModuleName "ForeignObj"
aDDR_Name = mkModuleName "Addr"
pREL_GHC = mkPrelModule pREL_GHC_Name
pREL_BASE = mkPrelModule pREL_BASE_Name
pREL_ADDR = mkPrelModule pREL_ADDR_Name
pREL_PTR = mkPrelModule pREL_PTR_Name
pREL_STABLE = mkPrelModule pREL_STABLE_Name
pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name
pREL_PACK = mkPrelModule pREL_PACK_Name
......@@ -423,28 +428,31 @@ returnIOName = varQual pREL_IO_BASE_Name SLIT("returnIO") returnIOIdKey
int8TyConName = tcQual pREL_INT_Name SLIT("Int8") int8TyConKey
int16TyConName = tcQual pREL_INT_Name SLIT("Int16") int16TyConKey
int32TyConName = tcQual pREL_INT_Name SLIT("Int32") int32TyConKey
int64TyConName = tcQual pREL_ADDR_Name SLIT("Int64") int64TyConKey
int64TyConName = tcQual pREL_INT_Name SLIT("Int64") int64TyConKey
word8TyConName = tcQual pREL_WORD_Name SLIT("Word8") word8TyConKey
word16TyConName = tcQual pREL_WORD_Name SLIT("Word16") word16TyConKey
word32TyConName = tcQual pREL_WORD_Name SLIT("Word32") word32TyConKey
word64TyConName = tcQual pREL_WORD_Name SLIT("Word64") word64TyConKey
wordTyConName = tcQual pREL_ADDR_Name SLIT("Word") wordTyConKey
wordDataConName = dataQual pREL_ADDR_Name SLIT("W#") wordDataConKey
word8TyConName = tcQual pREL_WORD_Name SLIT("Word8") word8TyConKey
word16TyConName = tcQual pREL_WORD_Name SLIT("Word16") word16TyConKey
word32TyConName = tcQual pREL_WORD_Name SLIT("Word32") word32TyConKey
word64TyConName = tcQual pREL_ADDR_Name SLIT("Word64") word64TyConKey
wordTyConName = tcQual pREL_WORD_Name SLIT("Word") wordTyConKey
wordDataConName = dataQual pREL_WORD_Name SLIT("W#") wordDataConKey
addrTyConName = tcQual pREL_ADDR_Name SLIT("Addr") addrTyConKey
addrDataConName = dataQual pREL_ADDR_Name SLIT("A#") addrDataConKey
addrTyConName = tcQual aDDR_Name SLIT("Addr") addrTyConKey
addrDataConName = dataQual aDDR_Name SLIT("A#") addrDataConKey
ptrTyConName = tcQual pREL_PTR_Name SLIT("Ptr") ptrTyConKey
ptrDataConName = dataQual pREL_PTR_Name SLIT("Ptr") ptrDataConKey
-- Byte array types
byteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("ByteArray") byteArrayTyConKey
mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") mutableByteArrayTyConKey
-- Forign objects and weak pointers
foreignObjTyConName = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") foreignObjTyConKey
foreignObjDataConName = dataQual pREL_IO_BASE_Name SLIT("ForeignObj") foreignObjDataConKey
foreignPtrTyConName = tcQual pREL_FOREIGN_Name SLIT("ForeignPtr") foreignPtrTyConKey
foreignPtrDataConName = dataQual pREL_FOREIGN_Name SLIT("ForeignPtr") foreignPtrDataConKey
foreignObjTyConName = tcQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjTyConKey
foreignObjDataConName = dataQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjDataConKey
foreignPtrTyConName = tcQual pREL_IO_BASE_Name SLIT("ForeignPtr") foreignPtrTyConKey
foreignPtrDataConName = dataQual pREL_IO_BASE_Name SLIT("ForeignPtr") foreignPtrDataConKey
stablePtrTyConName = tcQual pREL_STABLE_Name SLIT("StablePtr") stablePtrTyConKey
stablePtrDataConName = dataQual pREL_STABLE_Name SLIT("StablePtr") stablePtrDataConKey
deRefStablePtrName = varQual pREL_STABLE_Name SLIT("deRefStablePtr") deRefStablePtrIdKey
......@@ -689,16 +697,17 @@ boxityConKey = mkPreludeTyConUnique 68
typeConKey = mkPreludeTyConUnique 69
threadIdPrimTyConKey = mkPreludeTyConUnique 70
bcoPrimTyConKey = mkPreludeTyConUnique 71
ptrTyConKey = mkPreludeTyConUnique 72
-- Usage type constructors
usageConKey = mkPreludeTyConUnique 72
usOnceTyConKey = mkPreludeTyConUnique 73
usManyTyConKey = mkPreludeTyConUnique 74
usageConKey = mkPreludeTyConUnique 73
usOnceTyConKey = mkPreludeTyConUnique 74
usManyTyConKey = mkPreludeTyConUnique 75
-- Generic Type Constructors
crossTyConKey = mkPreludeTyConUnique 75
plusTyConKey = mkPreludeTyConUnique 76
genUnitTyConKey = mkPreludeTyConUnique 77
crossTyConKey = mkPreludeTyConUnique 76
plusTyConKey = mkPreludeTyConUnique 77
genUnitTyConKey = mkPreludeTyConUnique 78
\end{code}
%************************************************************************
......@@ -726,12 +735,13 @@ stableNameDataConKey = mkPreludeDataConUnique 14
trueDataConKey = mkPreludeDataConUnique 15
wordDataConKey = mkPreludeDataConUnique 16
ioDataConKey = mkPreludeDataConUnique 17
ptrDataConKey = mkPreludeDataConUnique 18
-- Generic data constructors
crossDataConKey = mkPreludeDataConUnique 17
inlDataConKey = mkPreludeDataConUnique 18
inrDataConKey = mkPreludeDataConUnique 19
genUnitDataConKey = mkPreludeDataConUnique 20
crossDataConKey = mkPreludeDataConUnique 19
inlDataConKey = mkPreludeDataConUnique 20
inrDataConKey = mkPreludeDataConUnique 21
genUnitDataConKey = mkPreludeDataConUnique 22
\end{code}
%************************************************************************
......
......@@ -16,6 +16,9 @@ module TysWiredIn (
addrDataCon,
addrTy,
addrTyCon,
ptrDataCon,
ptrTy,
ptrTyCon,
boolTy,
boolTyCon,
charDataCon,
......@@ -69,14 +72,15 @@ module TysWiredIn (
wordTy,
wordTyCon,
isFFIArgumentTy, -- :: Bool -> Type -> Bool
isFFIResultTy, -- :: Type -> Bool
isFFIExternalTy, -- :: Type -> Bool
isFFIDynArgumentTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
isFFILabelTy, -- :: Type -> Bool
isAddrTy, -- :: Type -> Bool
isForeignPtrTy -- :: Type -> Bool
isFFIArgumentTy, -- :: DynFlags -> Bool -> Type -> Bool
isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
isFFIExportResultTy, -- :: Type -> Bool
isFFIExternalTy, -- :: Type -> Bool
isFFIDynArgumentTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
isFFILabelTy, -- :: Type -> Bool
isAddrTy, -- :: Type -> Bool
isForeignPtrTy -- :: Type -> Bool
) where
......@@ -131,6 +135,7 @@ wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons
data_tycons = genericTyCons ++
[ addrTyCon
, ptrTyCon
, boolTyCon
, charTyCon
, doubleTyCon
......@@ -331,6 +336,13 @@ isAddrTy :: Type -> Bool
isAddrTy = isTyCon addrTyConKey
\end{code}
\begin{code}
ptrTy = mkTyConTy ptrTyCon
ptrTyCon = pcNonRecDataTyCon ptrTyConName alpha_tyvar [(True,False)] [ptrDataCon]
ptrDataCon = pcDataCon ptrDataConName alpha_tyvar [] [addrPrimTy] ptrTyCon
\end{code}
\begin{code}
floatTy = mkTyConTy floatTyCon
......@@ -430,14 +442,14 @@ isFFIArgumentTy dflags is_safe ty
isFFIExternalTy :: Type -> Bool
-- Types that are allowed as arguments of a 'foreign export'
isFFIExternalTy ty = checkRepTyCon legalIncomingTyCon ty
isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
isFFIImportResultTy :: DynFlags -> Type -> Bool
isFFIImportResultTy dflags ty
= checkRepTyCon (legalFIResultTyCon dflags) ty
isFFIResultTy :: Type -> Bool
-- Types that are allowed as a result of a 'foreign import' or of a 'foreign export'
-- Maybe we should distinguish between import and export, but
-- here we just choose the more restrictive 'incoming' predicate
-- But we allow () as well
isFFIResultTy ty = checkRepTyCon (\tc -> tc == unitTyCon || legalIncomingTyCon tc) ty
isFFIExportResultTy :: Type -> Bool
isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
isFFIDynArgumentTy :: Type -> Bool
-- The argument type of a foreign import dynamic must be either Addr, or
......@@ -452,7 +464,7 @@ isFFIDynResultTy = checkRepTyCon (== addrTyCon)
isFFILabelTy :: Type -> Bool
-- The type of a foreign label must be either Addr, or
-- a newtype of Addr.
isFFILabelTy = checkRepTyCon (== addrTyCon)
isFFILabelTy = checkRepTyCon (\tc -> tc == addrTyCon || tc == ptrTyCon)
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
-- look through newtypes
......@@ -472,11 +484,11 @@ These chaps do the work; they are not exported
----------------------------------------------
\begin{code}
legalIncomingTyCon :: TyCon -> Bool
legalFEArgTyCon :: TyCon -> Bool
-- It's illegal to return foreign objects and (mutable)
-- bytearrays from a _ccall_ / foreign declaration
-- (or be passed them as arguments in foreign exported functions).
legalIncomingTyCon tc
legalFEArgTyCon tc
| getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ]
= False
......@@ -485,6 +497,22 @@ legalIncomingTyCon tc
| otherwise
= boxedMarshalableTyCon tc
legalFIResultTyCon :: DynFlags -> TyCon -> Bool
legalFIResultTyCon dflags tc
| getUnique tc `elem`
[ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ] = False
| tc == unitTyCon = True
| otherwise = marshalableTyCon dflags tc
legalFEResultTyCon :: TyCon -> Bool
legalFEResultTyCon tc
| getUnique tc `elem`
[ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ] = False
| tc == unitTyCon = True
| otherwise = boxedMarshalableTyCon tc
legalOutgoingTyCon :: DynFlags -> Bool -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
-- The boolean is true for a 'safe' call (when we don't want to
......@@ -500,10 +528,13 @@ marshalableTyCon dflags tc
|| boxedMarshalableTyCon tc
boxedMarshalableTyCon tc
= getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
, wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
= getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
, int32TyConKey, int64TyConKey
, wordTyConKey, word8TyConKey, word16TyConKey
, word32TyConKey, word64TyConKey
, floatTyConKey, doubleTyConKey
, addrTyConKey, charTyConKey, foreignObjTyConKey
, addrTyConKey, ptrTyConKey
, charTyConKey, foreignObjTyConKey
, foreignPtrTyConKey
, stablePtrTyConKey
, byteArrayTyConKey, mutableByteArrayTyConKey
......@@ -690,8 +721,3 @@ genUnitTyCon = pcNonRecDataTyCon genUnitTyConName [] [] [genUnitDataCon]
genUnitDataCon :: DataCon
genUnitDataCon = pcDataCon genUnitDataConName [] [] [] genUnitTyCon
\end{code}
......@@ -40,7 +40,8 @@ import Type ( splitFunTys
, splitTyConApp_maybe
, splitForAllTys
)
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy,
isFFIExportResultTy,
isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
isFFILabelTy
)
......@@ -170,11 +171,11 @@ checkForeignImport is_dynamic is_safe ty args res
getDOptsTc `thenTc` \ dflags ->
check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res
checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
| otherwise =
getDOptsTc `thenTc` \ dflags ->
mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res
checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM ()
checkForeignExport is_dynamic ty args res
......@@ -187,12 +188,13 @@ checkForeignExport is_dynamic ty args res
case splitFunTys arg of
(arg_tys, res_ty) ->
mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIExportResultTy res_ty
`thenTc_`
checkForeignRes False {-Must be IO-} isFFIDynResultTy res
_ -> check False (illegalForeignTyErr True{-Arg-} ty)
| otherwise =
mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res
checkForeignRes True {-NonIO ok-} isFFIExportResultTy res
checkForeignArg :: (Type -> Bool) -> Type -> TcM ()
checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
......
......@@ -62,7 +62,7 @@ import Type ( splitDFunTy, isTyVarTy,
)
import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import Name ( Name )
import SrcLoc ( SrcLoc )
......@@ -719,7 +719,7 @@ scrutiniseInstanceHead dflags clas inst_taus
Just (tycon, arg_tys) = maybe_tycon_app
ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
creturnable_type ty = isFFIResultTy ty
creturnable_type ty = isFFIImportResultTy dflags ty
\end{code}
......
......@@ -68,9 +68,15 @@ package_details installing =
, "PrelFloat_Fzh_static_info"
, "PrelFloat_Dzh_static_info"
, "PrelAddr_Azh_static_info"
, "PrelAddr_Wzh_static_info"
, "PrelAddr_I64zh_static_info"
, "PrelAddr_W64zh_static_info"
, "PrelWord_Wzh_static_info"
, "PrelInt_I8zh_static_info"
, "PrelInt_I16zh_static_info"
, "PrelInt_I32zh_static_info"
, "PrelInt_I64zh_static_info"
, "PrelWord_W8zh_static_info"
, "PrelWord_W16zh_static_info"
, "PrelWord_W32zh_static_info"
, "PrelWord_W64zh_static_info"
, "PrelStable_StablePtr_static_info"
, "PrelBase_Izh_con_info"
, "PrelBase_Czh_con_info"
......
/* ----------------------------------------------------------------------------
* $Id: RtsAPI.h,v 1.18 2000/11/07 17:05:47 simonmar Exp $
* $Id: RtsAPI.h,v 1.19 2001/01/11 17:25:56 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -48,15 +48,18 @@ HaskellObj rts_mkWord8 ( HsWord8 w );
HaskellObj rts_mkWord16 ( HsWord16 w );
HaskellObj rts_mkWord32 ( HsWord32 w );
HaskellObj rts_mkWord64 ( HsWord64 w );
HaskellObj rts_mkPtr ( HsPtr a );
HaskellObj rts_mkFloat ( HsFloat f );
HaskellObj rts_mkDouble ( HsDouble f );
HaskellObj rts_mkStablePtr ( HsStablePtr s );
HaskellObj rts_mkAddr ( HsAddr a );
HaskellObj rts_mkBool ( HsBool b );
HaskellObj rts_mkString ( char *s );
HaskellObj rts_apply ( HaskellObj, HaskellObj );
/* DEPRECATED (use rts_mkPtr): */
HaskellObj rts_mkAddr ( HsAddr a );
/* ----------------------------------------------------------------------------
Deconstructing Haskell objects
------------------------------------------------------------------------- */
......@@ -65,12 +68,15 @@ HsInt rts_getInt ( HaskellObj );
HsInt32 rts_getInt32 ( HaskellObj );
HsWord rts_getWord ( HaskellObj );
HsWord32 rts_getWord32 ( HaskellObj );
HsPtr rts_getPtr ( HaskellObj );
HsFloat rts_getFloat ( HaskellObj );
HsDouble rts_getDouble ( HaskellObj );
HsStablePtr rts_getStablePtr ( HaskellObj );
HsAddr rts_getAddr ( HaskellObj );
HsBool rts_getBool ( HaskellObj );
/* DEPRECATED (use rts_getPtr): */
HsAddr rts_getAddr ( HaskellObj );
/* ----------------------------------------------------------------------------
Evaluating Haskell expressions
......
% -----------------------------------------------------------------------------
% $Id: CPUTime.lhs,v 1.26 2001/01/11 07:04:16 qrczak Exp $
% $Id: CPUTime.lhs,v 1.27 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1995-2000
%
......@@ -25,7 +25,7 @@ import PrelBase ( Int(..) )
import PrelByteArr ( ByteArray(..), newIntArray )
import PrelArrExtra ( unsafeFreezeByteArray )
import PrelNum ( fromInt )
import PrelIOBase ( IOError, IOException(..),
import PrelIOBase ( IOException(..),
IOErrorType( UnsupportedOperation ),
unsafePerformIO, stToIO, ioException )
import Ratio
......
......@@ -22,7 +22,8 @@ endif
# Setting the standard variables
#
HC = $(GHC_INPLACE)
HC = $(GHC_INPLACE)
CC = $(GHC_INPLACE)
ifneq "$(DLLized)" "YES"
PACKAGE = -package-name std
......@@ -36,6 +37,8 @@ HSLIB = std
# we don't want PrelMain in the GHCi library.
GHCI_LIBOBJS = $(filter-out PrelMain.$(way_)o,$(HS_OBJS))
HS_SRCS += $(patsubst %.hsc,%.hs,$(wildcard *.hsc))
#-----------------------------------------------------------------------------
# Setting the GHC compile options
......
% -----------------------------------------------------------------------------
% $Id: PrelAddr.lhs,v 1.18 2000/11/07 10:42:56 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
\section[PrelAddr]{Module @PrelAddr@}
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
module PrelAddr (
Addr(..)
, nullAddr -- :: Addr
, alignAddr -- :: Addr -> Int -> Addr
, plusAddr -- :: Addr -> Int -> Addr
, minusAddr -- :: Addr -> Addr -> Int
, indexAddrOffAddr -- :: Addr -> Int -> Addr
, Word(..)
, wordToInt
, intToWord
, Word64(..)
, Int64(..)
) where
import PrelGHC
import PrelBase
infixl 5 `plusAddr`, `minusAddr`
\end{code}
\begin{code}
data Addr = A# Addr# deriving (Eq, Ord)
data Word = W# Word# deriving (Eq, Ord)
nullAddr :: Addr
nullAddr = A# (int2Addr# 0#)
alignAddr :: Addr -> Int -> Addr
alignAddr addr@(A# a) (I# i)
= case addr2Int# a of { ai ->
case remInt# ai i of {
0# -> addr;
n -> A# (int2Addr# (ai +# (i -# n))) }}
plusAddr :: Addr -> Int -> Addr
plusAddr (A# addr) (I# off) = A# (int2Addr# (addr2Int# addr +# off))
minusAddr :: Addr -> Addr -> Int
minusAddr (A# a1) (A# a2) = I# (addr2Int# a1 -# addr2Int# a2)
instance CCallable Addr
instance CReturnable Addr
instance CCallable Word
instance CReturnable Word
wordToInt :: Word -> Int
wordToInt (W# w#) = I# (word2Int# w#)
intToWord :: Int -> Word
intToWord (I# i#) = W# (int2Word# i#)
#if WORD_SIZE_IN_BYTES == 8
data Word64 = W64# Word#
data Int64 = I64# Int#
#else
data Word64 = W64# Word64# --deriving (Eq, Ord) -- Glasgow extension
data Int64 = I64# Int64# --deriving (Eq, Ord) -- Glasgow extension
#endif
instance CCallable Word64
instance CReturnable Word64
instance CCallable Int64
instance CReturnable Int64
indexAddrOffAddr :: Addr -> Int -> Addr
indexAddrOffAddr (A# addr#) n
= case n of { I# n# ->
case indexAddrOffAddr# addr# n# of { r# ->
(A# r#)}}
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1998-2000
%
\section[Bits]{The @Bits@ interface}
Defines the @Bits@ class containing bit-based operations.
See library document for details on the semantics of the
individual operations.
\begin{code}
module PrelBits where
#ifdef __GLASGOW_HASKELL__
import PrelGHC
import PrelBase
import PrelNum
#endif
--ADR: The fixity for .|. conflicts with that for .|. in Fran.
-- Removing all fixities is a fairly safe fix; fixing the "one fixity
-- per symbol per program" limitation in Hugs would take a lot longer.
#ifndef __HUGS__
infixl 8 `shift`, `rotate`
infixl 7 .&.
infixl 6 `xor`
infixl 5 .|.
#endif
class Num a => Bits a where
(.&.), (.|.), xor :: a -> a -> a
complement :: a -> a
shift :: a -> Int -> a
rotate :: a -> Int -> a
bit :: Int -> a
setBit :: a -> Int -> a
clearBit :: a -> Int -> a
complementBit :: a -> Int -> a
testBit :: a -> Int -> Bool
bitSize :: a -> Int
isSigned :: a -> Bool
bit i = shift 0x1 i
setBit x i = x .|. bit i
clearBit x i = x .&. complement (bit i)
complementBit x i = x `xor` bit i
testBit x i = (x .&. bit i) /= 0
shiftL, shiftR :: Bits a => a -> Int -> a
rotateL, rotateR :: Bits a => a -> Int -> a
shiftL a i = shift a i
shiftR a i = shift a (-i)
rotateL a i = rotate a i
rotateR a i = rotate a (-i)
\end{code}
% -----------------------------------------------------------------------------
% $Id: PrelByteArr.lhs,v 1.9 2000/12/12 12:19:58 simonmar Exp $
% $Id: PrelByteArr.lhs,v 1.10 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
......@@ -18,8 +18,6 @@ import PrelArr
import PrelFloat
import PrelST
import PrelBase
import PrelAddr
\end{code}
%*********************************************************
......@@ -64,13 +62,11 @@ it frequently. Now we've got the overloading specialiser things
might be different, though.
\begin{code}
newCharArray, newIntArray, newWordArray, newAddrArray, newFloatArray, newDoubleArray
newCharArray, newIntArray, newFloatArray, newDoubleArray
:: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-}
{-# SPECIALIZE newIntArray :: IPr -> ST s (MutableByteArray s Int) #-}
{-# SPECIALIZE newWordArray :: IPr -> ST s (MutableByteArray s Int) #-}
{-# SPECIALIZE newAddrArray :: IPr -> ST s (MutableByteArray s Int) #-}
{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-}
{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-}
......@@ -89,11 +85,6 @@ newWordArray (l,u) = ST $ \ s# ->
case (newByteArray# (wORD_SCALE n#) s#) of { (# s2#, barr# #) ->
(# s2#, MutableByteArray l u barr# #) }}
newAddrArray (l,u) = ST $ \ s# ->
case rangeSize (l,u) of { I# n# ->
case (newByteArray# (wORD_SCALE n#) s#) of { (# s2#, barr# #) ->
(# s2#, MutableByteArray l u barr# #) }}
newFloatArray (l,u) = ST $ \ s# ->
case rangeSize (l,u) of { I# n# ->
case (newByteArray# (fLOAT_SCALE n#) s#) of { (# s2#, barr# #) ->
......@@ -114,14 +105,11 @@ fLOAT_SCALE n = (case SIZEOF_FLOAT :: Int of I# x -> x *# n)
readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char
readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int
readWordArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Word
readAddrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr
readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float
readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double
{-# SPECIALIZE readCharArray :: MutableByteArray s Int -> Int -> ST s Char #-}
{-# SPECIALIZE readIntArray :: MutableByteArray s Int -> Int -> ST s Int #-}
{-# SPECIALIZE readAddrArray :: MutableByteArray s Int -> Int -> ST s Addr #-}
--NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-}
{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-}
......@@ -135,16 +123,6 @@ readIntArray (MutableByteArray l u barr#) n = ST $ \ s# ->
case readIntArray# barr# n# s# of { (# s2#, r# #) ->
(# s2#, I# r# #) }}
readWordArray (MutableByteArray l u barr#) n = ST $ \ s# ->
case (index (l,u) n) of { I# n# ->
case readWordArray# barr# n# s# of { (# s2#, r# #) ->
(# s2#, W# r# #) }}
readAddrArray (MutableByteArray l u barr#) n = ST $ \ s# ->
case (index (l,u) n) of { I# n# ->
case readAddrArray# barr# n# s# of { (# s2#, r# #) ->
(# s2#, A# r# #) }}
readFloatArray (MutableByteArray l u barr#) n = ST $ \ s# ->
case (index (l,u) n) of { I# n# ->
case readFloatArray# barr# n# s# of { (# s2#, r# #) ->
......@@ -158,14 +136,11 @@ readDoubleArray (MutableByteArray l u barr#) n = ST $ \ s# ->
--Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
indexCharArray :: Ix ix => ByteArray ix -> ix -> Char
indexIntArray :: Ix ix => ByteArray ix -> ix -> Int
indexWordArray :: Ix ix => ByteArray ix -> ix -> Word
indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr
indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float
indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double
{-# SPECIALIZE indexCharArray :: ByteArray Int -> Int -> Char #-}
{-# SPECIALIZE indexIntArray :: ByteArray Int -> Int -> Int #-}
{-# SPECIALIZE indexAddrArray :: ByteArray Int -> Int -> Addr #-}
--NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-}
{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-}
......@@ -179,16 +154,6 @@ indexIntArray (ByteArray l u barr#) n
case indexIntArray# barr# n# of { r# ->