From efa881239effd5ea4cb403c2c03ebb09fbdfd363 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 11 Jan 2001 17:25:59 +0000 Subject: [PATCH] [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. --- ghc/compiler/prelude/PrelNames.lhs | 56 ++- ghc/compiler/prelude/TysWiredIn.lhs | 78 ++-- ghc/compiler/typecheck/TcForeign.lhs | 12 +- ghc/compiler/typecheck/TcInstDcls.lhs | 4 +- ghc/driver/PackageSrc.hs | 12 +- ghc/includes/RtsAPI.h | 12 +- ghc/lib/std/CPUTime.lhs | 4 +- ghc/lib/std/{Directory.lhs => Directory.hsc} | 442 +++++++++---------- ghc/lib/std/Makefile | 5 +- ghc/lib/std/PrelAddr.lhs | 88 ---- ghc/lib/std/PrelBits.lhs | 54 +++ ghc/lib/std/PrelByteArr.lhs | 52 +-- ghc/lib/std/PrelCError.lhs | 594 ++++++++++++++++++++++++++ ghc/lib/std/PrelCString.lhs | 143 +++++++ ghc/lib/std/PrelCTypes.lhs | 81 ++++ ghc/lib/std/PrelCTypesISO.lhs | 66 +++ ghc/lib/std/PrelDynamic.lhs | 4 +- ghc/lib/std/PrelForeign.lhs | 110 ++--- ghc/lib/std/PrelHandle.lhs | 76 ++-- ghc/lib/std/PrelIO.lhs | 57 ++- ghc/lib/std/PrelIOBase.lhs | 43 +- ghc/lib/std/PrelInt.lhs | 324 ++++++++------ ghc/lib/std/PrelMarshalAlloc.lhs | 105 +++++ ghc/lib/std/PrelMarshalArray.lhs | 205 +++++++++ ghc/lib/std/PrelMarshalError.lhs | 71 +++ ghc/lib/std/PrelMarshalUtils.lhs | 152 +++++++ ghc/lib/std/PrelPack.lhs | 41 +- ghc/lib/std/PrelPosixTypes.hsc | 30 ++ ghc/lib/std/PrelPtr.lhs | 60 +++ ghc/lib/std/PrelStorable.lhs | 302 +++++++++++++ ghc/lib/std/PrelWeak.lhs | 9 +- ghc/lib/std/PrelWord.lhs | 446 ++++++++++--------- ghc/lib/std/System.lhs | 164 ++----- ghc/lib/std/Time.lhs | 8 +- ghc/lib/std/cbits/CTypes.h | 352 +++++++++++++++ ghc/lib/std/cbits/createDirectory.c | 63 --- ghc/lib/std/cbits/directoryAux.c | 128 ------ ghc/lib/std/cbits/getCurrentDirectory.c | 47 -- ghc/lib/std/cbits/getDirectoryContents.c | 125 ------ ghc/lib/std/cbits/progargs.c | 6 +- ghc/lib/std/cbits/removeDirectory.c | 56 --- ghc/lib/std/cbits/removeFile.c | 46 -- ghc/lib/std/cbits/renameDirectory.c | 48 --- ghc/lib/std/cbits/renameFile.c | 84 ---- ghc/lib/std/cbits/setCurrentDirectory.c | 24 -- ghc/rts/Prelude.h | 65 ++- ghc/rts/RtsAPI.c | 51 +-- ghc/rts/RtsAPIDeprec.c | 34 ++ 48 files changed, 3235 insertions(+), 1804 deletions(-) rename ghc/lib/std/{Directory.lhs => Directory.hsc} (55%) delete mode 100644 ghc/lib/std/PrelAddr.lhs create mode 100644 ghc/lib/std/PrelBits.lhs create mode 100644 ghc/lib/std/PrelCError.lhs create mode 100644 ghc/lib/std/PrelCString.lhs create mode 100644 ghc/lib/std/PrelCTypes.lhs create mode 100644 ghc/lib/std/PrelCTypesISO.lhs create mode 100644 ghc/lib/std/PrelMarshalAlloc.lhs create mode 100644 ghc/lib/std/PrelMarshalArray.lhs create mode 100644 ghc/lib/std/PrelMarshalError.lhs create mode 100644 ghc/lib/std/PrelMarshalUtils.lhs create mode 100644 ghc/lib/std/PrelPosixTypes.hsc create mode 100644 ghc/lib/std/PrelPtr.lhs create mode 100644 ghc/lib/std/PrelStorable.lhs create mode 100644 ghc/lib/std/cbits/CTypes.h delete mode 100644 ghc/lib/std/cbits/createDirectory.c delete mode 100644 ghc/lib/std/cbits/directoryAux.c delete mode 100644 ghc/lib/std/cbits/getCurrentDirectory.c delete mode 100644 ghc/lib/std/cbits/getDirectoryContents.c delete mode 100644 ghc/lib/std/cbits/removeDirectory.c delete mode 100644 ghc/lib/std/cbits/removeFile.c delete mode 100644 ghc/lib/std/cbits/renameDirectory.c delete mode 100644 ghc/lib/std/cbits/renameFile.c delete mode 100644 ghc/lib/std/cbits/setCurrentDirectory.c create mode 100644 ghc/rts/RtsAPIDeprec.c diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 37d44a2..4015b8d 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -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} %************************************************************************ diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index a4b33c8..73ef625 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -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 @@ -332,6 +337,13 @@ 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 floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] @@ -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} - - - - - diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 8208083..875d974 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -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) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index f6477df..6f78e39 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -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} diff --git a/ghc/driver/PackageSrc.hs b/ghc/driver/PackageSrc.hs index 33bbd1b..e9113d7 100644 --- a/ghc/driver/PackageSrc.hs +++ b/ghc/driver/PackageSrc.hs @@ -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" diff --git a/ghc/includes/RtsAPI.h b/ghc/includes/RtsAPI.h index a78aa7a..8baf34f 100644 --- a/ghc/includes/RtsAPI.h +++ b/ghc/includes/RtsAPI.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $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 diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs index a695214..c5c7bc7 100644 --- a/ghc/lib/std/CPUTime.lhs +++ b/ghc/lib/std/CPUTime.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $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 diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.hsc similarity index 55% rename from ghc/lib/std/Directory.lhs rename to ghc/lib/std/Directory.hsc index 9ade44d..e3760e4 100644 --- a/ghc/lib/std/Directory.lhs +++ b/ghc/lib/std/Directory.hsc @@ -1,11 +1,12 @@ -% ----------------------------------------------------------------------------- -% $Id: Directory.lhs,v 1.21 2001/01/11 07:04:16 qrczak Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% +-- ----------------------------------------------------------------------------- +-- $Id: Directory.hsc,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +-- +-- (c) The University of Glasgow, 1994-2000 +-- -\section[Directory]{Directory interface} +-- The Directory Interface +{- A directory contains a series of entries, each of which is a named reference to a file system object (file, directory etc.). Some entries may be hidden, inaccessible, or have some administrative @@ -18,9 +19,8 @@ Each file system object is referenced by a {\em path}. There is normally at least one absolute path to each file system object. In some operating systems, it may also be possible to have paths which are relative to the current directory. +-} -\begin{code} -{-# OPTIONS -#include -#include -#include "cbits/stgio.h" #-} module Directory ( Permissions -- abstract @@ -47,62 +47,52 @@ module Directory , getPermissions -- :: FilePath -> IO Permissions , setPermissions -- :: FilePath -> Permissions -> IO () - -#ifndef __HUGS__ , getModificationTime -- :: FilePath -> IO ClockTime -#endif ) where -#ifdef __HUGS__ ---import PreludeBuiltin -#else - import Prelude -- Just to get it in the dependencies -import PrelGHC ( RealWorld, or#, and# ) -import PrelByteArr ( ByteArray, MutableByteArray, - newWordArray, readWordArray, newCharArray ) -import PrelArrExtra ( unsafeFreezeByteArray ) -import PrelPack ( packString, unpackCStringST ) -import PrelIOBase ( stToIO, - constructErrorAndFail, constructErrorAndFailWithInfo, - IOException(..), ioException, IOErrorType(SystemError) ) import Time ( ClockTime(..) ) -import PrelAddr ( Addr, nullAddr, Word(..), wordToInt, intToWord ) -#endif - -\end{code} -%********************************************************* -%* * -\subsection{Permissions} -%* * -%********************************************************* +import PrelStorable +import PrelCString +import PrelMarshalAlloc +import PrelCTypes +import PrelPosixTypes +import PrelCError +import PrelPtr +import PrelIOBase +import PrelBase + +#include +#include +#include +#include +#include + +----------------------------------------------------------------------------- +-- Permissions + +-- The @Permissions@ type is used to record whether certain +-- operations are permissible on a file/directory: +-- [to whom? - presumably the "current user"] -The @Permissions@ type is used to record whether certain -operations are permissible on a file/directory: -[to whom? - owner/group/world - the Report don't say much] - -\begin{code} data Permissions = Permissions { readable, writable, executable, searchable :: Bool } deriving (Eq, Ord, Read, Show) -\end{code} -%********************************************************* -%* * -\subsection{Implementation} -%* * -%********************************************************* +----------------------------------------------------------------------------- +-- Implementation -@createDirectory dir@ creates a new directory {\em dir} which is -initially empty, or as near to empty as the operating system -allows. +-- @createDirectory dir@ creates a new directory {\em dir} which is +-- initially empty, or as near to empty as the operating system +-- allows. -The operation may fail with: +-- The operation may fail with: +{- \begin{itemize} \item @isPermissionError@ / @PermissionDenied@ The process has insufficient privileges to perform the operation. @@ -127,15 +117,19 @@ physical disk space, etc.) are available to perform the operation. The path refers to an existing non-directory object. @[EEXIST]@ \end{itemize} +-} -\begin{code} createDirectory :: FilePath -> IO () createDirectory path = do - rc <- primCreateDirectory (primPackString path) - if rc == 0 then return () else - constructErrorAndFailWithInfo "createDirectory" path -\end{code} + withUnsafeCString path $ \s -> do + throwErrnoIfMinus1Retry_ "createDirectory" $ +#if defined(mingw32_TARGET_OS) + mkdir s +#else + mkdir s 0o777 +#endif +{- @removeDirectory dir@ removes an existing directory {\em dir}. The implementation may specify additional constraints which must be satisfied before a directory can be removed (e.g. the directory has to @@ -169,18 +163,15 @@ The implementation does not support removal in this situation. The operand refers to an existing non-directory object. @[ENOTDIR]@ \end{itemize} +-} -\begin{code} removeDirectory :: FilePath -> IO () removeDirectory path = do - rc <- primRemoveDirectory (primPackString path) - if rc == 0 then - return () - else - constructErrorAndFailWithInfo "removeDirectory" path -\end{code} - -@removeFile file@ removes the directory entry for an existing file + withUnsafeCString path $ \s -> + throwErrnoIfMinus1Retry_ "removeDirectory" (rmdir s) + +{- +@Removefile file@ removes the directory entry for an existing file {\em file}, where {\em file} is not itself a directory. The implementation may specify additional constraints which must be satisfied before a file can be removed (e.g. the file may not be in @@ -207,17 +198,14 @@ Implementation-dependent constraints are not satisfied. The operand refers to an existing directory. @[EPERM, EINVAL]@ \end{itemize} +-} -\begin{code} removeFile :: FilePath -> IO () removeFile path = do - rc <- primRemoveFile (primPackString path) - if rc == 0 then - return () - else - constructErrorAndFailWithInfo "removeFile" path -\end{code} + withUnsafeCString path $ \s -> + throwErrnoIfMinus1Retry_ "removeFile" (unlink s) +{- @renameDirectory old@ {\em new} changes the name of an existing directory from {\em old} to {\em new}. If the {\em new} directory already exists, it is atomically replaced by the {\em old} directory. @@ -255,17 +243,22 @@ The implementation does not support renaming in this situation. Either path refers to an existing non-directory object. @[ENOTDIR, EISDIR]@ \end{itemize} +-} -\begin{code} renameDirectory :: FilePath -> FilePath -> IO () -renameDirectory opath npath = do - rc <- primRenameDirectory (primPackString opath) (primPackString npath) - if rc == 0 then - return () - else - constructErrorAndFailWithInfo "renameDirectory" ("old: " ++ opath ++ ",new: " ++ npath) -\end{code} - +renameDirectory opath npath = + withFileStatus opath $ \st -> do + is_dir <- isDirectory st + if (not is_dir) + then ioException (IOError Nothing InappropriateType "renameDirectory" + ("not a directory") (Just opath)) + else do + + withUnsafeCString opath $ \s1 -> + withUnsafeCString npath $ \s2 -> + throwErrnoIfMinus1Retry_ "renameDirectory" (rename s1 s2) + +{- @renameFile@ {\em old} {\em new} changes the name of an existing file system object from {\em old} to {\em new}. If the {\em new} object already exists, it is atomically replaced by the {\em old} object. Neither @@ -301,17 +294,22 @@ The implementation does not support renaming in this situation. Either path refers to an existing directory. @[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ \end{itemize} +-} -\begin{code} renameFile :: FilePath -> FilePath -> IO () -renameFile opath npath = do - rc <- primRenameFile (primPackString opath) (primPackString npath) - if rc == 0 then - return () - else - constructErrorAndFailWithInfo "renameFile" opath -\end{code} - +renameFile opath npath = + withFileStatus opath $ \st -> do + is_dir <- isDirectory st + if is_dir + then ioException (IOError Nothing InappropriateType "renameFile" + "is a directory" (Just opath)) + else do + + withUnsafeCString opath $ \s1 -> + withUnsafeCString npath $ \s2 -> + throwErrnoIfMinus1Retry_ "renameFile" (rename s1 s2) + +{- @getDirectoryContents dir@ returns a list of {\em all} entries in {\em dir}. @@ -336,30 +334,29 @@ Insufficient resources are available to perform the operation. The path refers to an existing non-directory object. @[ENOTDIR]@ \end{itemize} +-} -\begin{code} getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path = do - dir <- primOpenDir (primPackString path) - if dir == nullAddr - then constructErrorAndFailWithInfo "getDirectoryContents" path - else loop dir + p <- withUnsafeCString path $ \s -> + throwErrnoIfNullRetry "getDirectoryContents" (opendir s) + loop p where - loop :: Addr -> IO [String] - loop dir = do - dirent_ptr <- primReadDir dir - if dirent_ptr == nullAddr - then do - -- readDir__ implicitly performs closedir() when the - -- end is reached. - return [] - else do - str <- primGetDirentDName dirent_ptr - entry <- primUnpackCString str - entries <- loop dir - return (entry:entries) -\end{code} - + loop :: Ptr CDir -> IO [String] + loop dir = do + p <- readdir dir + if (p /= nullPtr) + then do entry <- peekCString ((#ptr struct dirent,d_name) p) + entries <- loop dir + return (entry:entries) + else do errno <- getErrno + if (errno == eINTR) then loop dir else do + throwErrnoIfMinus1_ "getDirectoryContents" $ closedir dir + if (isValidErrno errno) -- EOF + then throwErrno "getDirectoryContents" + else return [] + +{- If the operating system has a notion of current directories, @getCurrentDirectory@ returns an absolute path to the current directory of the calling process. @@ -380,20 +377,26 @@ Insufficient resources are available to perform the operation. \item @UnsupportedOperation@ The operating system has no notion of current directory. \end{itemize} +-} -\begin{code} getCurrentDirectory :: IO FilePath getCurrentDirectory = do - str <- primGetCurrentDirectory - if str /= nullAddr - then do - pwd <- primUnpackCString str - primFree str - return pwd - else - constructErrorAndFail "getCurrentDirectory" -\end{code} - + p <- mallocBytes (#const PATH_MAX) + go p (#const PATH_MAX) + where go p bytes = do + p' <- getcwd p (fromIntegral bytes) + if p' /= nullPtr + then do s <- peekCString p' + free p' + return s + else do errno <- getErrno + if errno == eRANGE + then do let bytes' = bytes * 2 + p' <- reallocBytes p bytes' + go p' bytes' + else throwErrno "getCurrentDirectory" + +{- If the operating system has a notion of current directories, @setCurrentDirectory dir@ changes the current directory of the calling process to {\em dir}. @@ -419,186 +422,123 @@ current directory cannot be dynamically changed. The path refers to an existing non-directory object. @[ENOTDIR]@ \end{itemize} +-} -\begin{code} setCurrentDirectory :: FilePath -> IO () setCurrentDirectory path = do - rc <- primSetCurrentDirectory (primPackString path) - if rc == 0 - then return () - else constructErrorAndFailWithInfo "setCurrentDirectory" path -\end{code} + withUnsafeCString path $ \s -> + throwErrnoIfMinus1Retry_ "setCurrentDirectory" (chdir s) + -- ToDo: add path to error +{- To clarify, @doesDirectoryExist@ returns True if a file system object exist, and it's a directory. @doesFileExist@ returns True if the file system object exist, but it's not a directory (i.e., for every other file system object that is not a directory.) +-} -\begin{code} doesDirectoryExist :: FilePath -> IO Bool doesDirectoryExist name = catch - (getFileStatus name >>= \ st -> return (isDirectory st)) + (withFileStatus name $ \st -> isDirectory st) (\ _ -> return False) doesFileExist :: FilePath -> IO Bool doesFileExist name = do catch - (getFileStatus name >>= \ st -> return (not (isDirectory st))) + (withFileStatus name $ \st -> do b <- isDirectory st; return (not b)) (\ _ -> return False) -#ifndef __HUGS__ getModificationTime :: FilePath -> IO ClockTime getModificationTime name = - getFileStatus name >>= \ st -> + withFileStatus name $ \ st -> modificationTime st -#endif getPermissions :: FilePath -> IO Permissions getPermissions name = do - st <- getFileStatus name - read <- primAccess (primPackString name) readOK - write <- primAccess (primPackString name) writeOK - exec <- primAccess (primPackString name) executeOK - + withUnsafeCString name $ \s -> do + read <- access s (#const R_OK) + write <- access s (#const W_OK) + exec <- access s (#const X_OK) + withFileStatus name $ \st -> do + is_dir <- isDirectory st + is_reg <- isRegularFile st return ( Permissions { readable = read == 0, writable = write == 0, - executable = not (isDirectory st) && exec == 0, - searchable = not (isRegularFile st) && exec == 0 + executable = not is_dir && exec == 0, + searchable = not is_reg && exec == 0 } ) setPermissions :: FilePath -> Permissions -> IO () setPermissions name (Permissions r w e s) = do let - read = if r then ownerReadMode else emptyFileMode - write = if w then ownerWriteMode else emptyFileMode - exec = if e || s then ownerExecuteMode else emptyFileMode - - mode = read `unionFileMode` (write `unionFileMode` exec) - - rc <- primChmod (primPackString name) mode - if rc == 0 - then return () - else ioException (IOError Nothing SystemError - "setPermissions" "insufficient permissions" (Just name)) -\end{code} - -(Sigh)..copied from Posix.Files to avoid dep. on posix library - -\begin{code} -type FileStatus = PrimByteArray - -getFileStatus :: FilePath -> IO FileStatus -getFileStatus name = do - bytes <- primNewByteArray sizeof_stat - rc <- primStat (primPackString name) bytes - if rc == 0 -#ifdef __HUGS__ - then primUnsafeFreezeByteArray bytes -#else - then stToIO (unsafeFreezeByteArray bytes) -#endif - else ioException (IOError Nothing SystemError - "getFileStatus" "" (Just name)) - -#ifndef __HUGS__ -modificationTime :: FileStatus -> IO ClockTime -modificationTime stat = do - i1 <- stToIO (newWordArray (0,1)) - setFileMode i1 stat - secs <- stToIO (readWordArray i1 0) - return (TOD (toInteger (wordToInt secs)) 0) - -foreign import ccall "libHS_cbits" "set_stat_st_mtime" unsafe - setFileMode :: PrimMutableByteArray RealWorld -> FileStatus -> IO () -#endif - -isDirectory :: FileStatus -> Bool -isDirectory stat = prim_S_ISDIR (fileMode stat) /= 0 + read = if r then (#const S_IRUSR) else emptyCMode + write = if w then (#const S_IWUSR) else emptyCMode + exec = if e || s then (#const S_IXUSR) else emptyCMode -isRegularFile :: FileStatus -> Bool -isRegularFile stat = prim_S_ISREG (fileMode stat) /= 0 + mode = read `unionCMode` (write `unionCMode` exec) -foreign import ccall "libHS_cbits" "sizeof_stat" unsafe sizeof_stat :: Int -foreign import ccall "libHS_cbits" "prim_stat" unsafe - primStat :: PrimByteArray -> PrimMutableByteArray RealWorld -> IO Int + withUnsafeCString name $ \s -> + throwErrnoIfMinus1_ "setPermissions" $ chmod s mode -foreign import ccall "libHS_cbits" "get_stat_st_mode" unsafe fileMode :: FileStatus -> FileMode -foreign import ccall "libHS_cbits" "prim_S_ISDIR" unsafe prim_S_ISDIR :: FileMode -> Int -foreign import ccall "libHS_cbits" "prim_S_ISREG" unsafe prim_S_ISREG :: FileMode -> Int -\end{code} +withFileStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a +withFileStatus name f = do + allocaBytes (#const sizeof(struct stat)) $ \p -> + withUnsafeCString name $ \s -> do + throwErrnoIfMinus1Retry_ "withFileStatus" (stat s p) + f p -\begin{code} -type FileMode = Word - -emptyFileMode :: FileMode -unionFileMode :: FileMode -> FileMode -> FileMode -intersectFileMode :: FileMode -> FileMode -> FileMode - -foreign import ccall "libHS_cbits" "const_S_IRUSR" unsafe ownerReadMode :: FileMode -foreign import ccall "libHS_cbits" "const_S_IWUSR" unsafe ownerWriteMode :: FileMode -foreign import ccall "libHS_cbits" "const_S_IXUSR" unsafe ownerExecuteMode :: FileMode - -#ifdef __HUGS__ -emptyFileMode = primIntToWord 0 -unionFileMode = primOrWord -intersectFileMode = primAndWord -#else -emptyFileMode = intToWord 0 -unionFileMode = orWord -intersectFileMode = andWord -#endif -\end{code} +modificationTime :: Ptr CStat -> IO ClockTime +modificationTime stat = do + mtime <- (#peek struct stat, st_mtime) stat + return (TOD (toInteger (mtime :: CTime)) 0) -\begin{code} -type AccessMode = Word +isDirectory :: Ptr CStat -> IO Bool +isDirectory stat = do + mode <- (#peek struct stat, st_mode) stat + return (s_ISDIR mode /= 0) -foreign import ccall "libHS_cbits" "const_R_OK" unsafe readOK :: AccessMode -foreign import ccall "libHS_cbits" "const_W_OK" unsafe writeOK :: AccessMode -foreign import ccall "libHS_cbits" "const_X_OK" unsafe executeOK :: AccessMode -\end{code} +isRegularFile :: Ptr CStat -> IO Bool +isRegularFile stat = do + mode <- (#peek struct stat, st_mode) stat + return (s_ISREG mode /= 0) -Some defns. to allow us to share code. +foreign import ccall unsafe s_ISDIR :: CMode -> Int +#def inline HsInt s_ISDIR(m) {return S_ISDIR(m);} -\begin{code} -#ifndef __HUGS__ +foreign import ccall unsafe s_ISREG :: CMode -> Int +#def inline HsInt s_ISREG(m) {return S_ISREG(m);} -primPackString :: [Char] -> ByteArray Int -primPackString = packString ---ToDo: fix. -primUnpackCString :: Addr -> IO String -primUnpackCString a = stToIO (unpackCStringST a) +emptyCMode :: CMode +emptyCMode = 0 -type PrimByteArray = ByteArray Int -type PrimMutableByteArray s = MutableByteArray RealWorld Int -type CString = PrimByteArray +unionCMode :: CMode -> CMode -> CMode +unionCMode = (+) -orWord, andWord :: Word -> Word -> Word -orWord (W# x#) (W# y#) = W# (x# `or#` y#) -andWord (W# x#) (W# y#) = W# (x# `and#` y#) +type UCString = UnsafeCString -primNewByteArray :: Int -> IO (PrimMutableByteArray s) -primNewByteArray sz_in_bytes = stToIO (newCharArray (0,sz_in_bytes)) +#if defined(mingw32_TARGET_OS) +foreign import ccall unsafe mkdir :: UCString -> IO CInt +#else +foreign import ccall unsafe mkdir :: UCString -> CInt -> IO CInt #endif -foreign import ccall "libHS_cbits" "createDirectory" unsafe primCreateDirectory :: CString -> IO Int -foreign import ccall "libHS_cbits" "removeDirectory" unsafe primRemoveDirectory :: CString -> IO Int -foreign import ccall "libHS_cbits" "removeFile" unsafe primRemoveFile :: CString -> IO Int -foreign import ccall "libHS_cbits" "renameDirectory" unsafe primRenameDirectory :: CString -> CString -> IO Int -foreign import ccall "libHS_cbits" "renameFile" unsafe primRenameFile :: CString -> CString -> IO Int -foreign import ccall "libHS_cbits" "openDir__" unsafe primOpenDir :: CString -> IO Addr -foreign import ccall "libHS_cbits" "readDir__" unsafe primReadDir :: Addr -> IO Addr -foreign import ccall "libHS_cbits" "get_dirent_d_name" unsafe primGetDirentDName :: Addr -> IO Addr -foreign import ccall "libHS_cbits" "setCurrentDirectory" unsafe primSetCurrentDirectory :: CString -> IO Int -foreign import ccall "libHS_cbits" "getCurrentDirectory" unsafe primGetCurrentDirectory :: IO Addr -foreign import ccall "libc" "free" unsafe primFree :: Addr -> IO () -foreign import ccall "libc" "malloc" unsafe primMalloc :: Word -> IO Addr -foreign import ccall "libc" "chmod" unsafe primChmod :: CString -> Word -> IO Int - -foreign import ccall "libc" "access" unsafe - primAccess :: CString -> Word -> IO Int -\end{code} - +foreign import ccall unsafe chmod :: UCString -> CMode -> IO CInt +foreign import ccall unsafe access :: UCString -> CMode -> IO CInt +foreign import ccall unsafe rmdir :: UCString -> IO CInt +foreign import ccall unsafe chdir :: UCString -> IO CInt +foreign import ccall unsafe getcwd :: Ptr CChar -> CInt -> IO (Ptr CChar) +foreign import ccall unsafe unlink :: UCString -> IO CInt +foreign import ccall unsafe rename :: UCString -> UCString -> IO CInt + +foreign import ccall unsafe opendir :: UCString -> IO (Ptr CDir) +foreign import ccall unsafe readdir :: Ptr CDir -> IO (Ptr CDirent) +foreign import ccall unsafe closedir :: Ptr CDir -> IO CInt + +foreign import ccall unsafe stat :: UCString -> Ptr CStat -> IO CInt + +type CDirent = () +type CStat = () diff --git a/ghc/lib/std/Makefile b/ghc/lib/std/Makefile index 0379264..075c706 100644 --- a/ghc/lib/std/Makefile +++ b/ghc/lib/std/Makefile @@ -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 diff --git a/ghc/lib/std/PrelAddr.lhs b/ghc/lib/std/PrelAddr.lhs deleted file mode 100644 index 4ce5bf3..0000000 --- a/ghc/lib/std/PrelAddr.lhs +++ /dev/null @@ -1,88 +0,0 @@ -% ----------------------------------------------------------------------------- -% $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} - diff --git a/ghc/lib/std/PrelBits.lhs b/ghc/lib/std/PrelBits.lhs new file mode 100644 index 0000000..24df47b --- /dev/null +++ b/ghc/lib/std/PrelBits.lhs @@ -0,0 +1,54 @@ +% +% (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} diff --git a/ghc/lib/std/PrelByteArr.lhs b/ghc/lib/std/PrelByteArr.lhs index 5c39092..76e6d17 100644 --- a/ghc/lib/std/PrelByteArr.lhs +++ b/ghc/lib/std/PrelByteArr.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $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# -> (I# r#)}} -indexWordArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexWordArray# barr# n# of { r# -> - (W# r#)}} - -indexAddrArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexAddrArray# barr# n# of { r# -> - (A# r#)}} - indexFloatArray (ByteArray l u barr#) n = case (index (l,u) n) of { I# n# -> case indexFloatArray# barr# n# of { r# -> @@ -201,14 +166,11 @@ indexDoubleArray (ByteArray l u barr#) n writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s () writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s () -writeWordArray :: Ix ix => MutableByteArray s ix -> ix -> Word -> ST s () -writeAddrArray :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s () writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s () writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s () {-# SPECIALIZE writeCharArray :: MutableByteArray s Int -> Int -> Char -> ST s () #-} {-# SPECIALIZE writeIntArray :: MutableByteArray s Int -> Int -> Int -> ST s () #-} -{-# SPECIALIZE writeAddrArray :: MutableByteArray s Int -> Int -> Addr -> ST s () #-} --NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-} {-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-} @@ -222,16 +184,6 @@ writeIntArray (MutableByteArray l u barr#) n (I# ele) = ST $ \ s# -> case writeIntArray# barr# n# ele s# of { s2# -> (# s2#, () #) }} -writeWordArray (MutableByteArray l u barr#) n (W# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeWordArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - -writeAddrArray (MutableByteArray l u barr#) n (A# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeAddrArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - writeFloatArray (MutableByteArray l u barr#) n (F# ele) = ST $ \ s# -> case index (l,u) n of { I# n# -> case writeFloatArray# barr# n# ele s# of { s2# -> diff --git a/ghc/lib/std/PrelCError.lhs b/ghc/lib/std/PrelCError.lhs new file mode 100644 index 0000000..8455321 --- /dev/null +++ b/ghc/lib/std/PrelCError.lhs @@ -0,0 +1,594 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelCError.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +% +% (c) The FFI task force, 2000 +% + +C-specific Marshalling support: Handling of C "errno" error codes + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +-- this is were we get the CCONST_XXX definitions from that configure +-- calculated for us +-- +#include "config.h" + +module PrelCError ( + + -- Haskell representation for "errno" values + -- + Errno(..), -- instance: Eq + e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, + eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, + eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, + eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, + eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, + eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, + eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, + eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, + eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, + eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, + ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, + eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, + eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, + eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV, + -- :: Errno + isValidErrno, -- :: Errno -> Bool + + -- access to the current thread's "errno" value + -- + getErrno, -- :: IO Errno + + -- conversion of an "errno" value into IO error + -- + errnoToIOError, -- :: String -- location + -- -> Errno -- errno + -- -> Maybe Handle -- handle + -- -> Maybe String -- filename + -- -> IOError + + -- throw current "errno" value + -- + throwErrno, -- :: String -> IO a + + -- guards for IO operations that may fail + -- + throwErrnoIf, -- :: (a -> Bool) -> String -> IO a -> IO a + throwErrnoIf_, -- :: (a -> Bool) -> String -> IO a -> IO () + throwErrnoIfRetry, -- :: (a -> Bool) -> String -> IO a -> IO a + throwErrnoIfRetry_, -- :: (a -> Bool) -> String -> IO a -> IO () + throwErrnoIfMinus1, -- :: Num a + -- => String -> IO a -> IO a + throwErrnoIfMinus1_, -- :: Num a + -- => String -> IO a -> IO () + throwErrnoIfMinus1Retry, + -- :: Num a + -- => String -> IO a -> IO a + throwErrnoIfMinus1Retry_, + -- :: Num a + -- => String -> IO a -> IO () + throwErrnoIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a) + throwErrnoIfNullRetry -- :: String -> IO (Ptr a) -> IO (Ptr a) +) where + + +-- system dependent imports +-- ------------------------ + +-- GHC allows us to get at the guts inside IO errors/exceptions +-- +#if __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ < 409 +import PrelIOBase (IOError(..), IOErrorType(..)) +#else +import PrelIOBase (Exception(..), IOException(..), IOErrorType(..)) +#endif +#endif /* __GLASGOW_HASKELL__ */ + + +-- regular imports +-- --------------- + +import Monad (liftM) + +#if __GLASGOW_HASKELL__ +import PrelStorable +import PrelMarshalError +import PrelCTypes +import PrelIOBase +import PrelPtr +import PrelNum +import PrelShow +import PrelMaybe +import PrelBase +#else +import Ptr (Ptr, nullPtr) +import CTypes (CInt) +import MarshalError (void) + +import IO (IOError, Handle, ioError) +#endif + +-- system dependent re-definitions +-- ------------------------------- + +-- we bring GHC's `IOErrorType' in scope in other compilers to simplify the +-- routine `errnoToIOError' below +-- +#if !__GLASGOW_HASKELL__ +data IOErrorType + = AlreadyExists | HardwareFault + | IllegalOperation | InappropriateType + | Interrupted | InvalidArgument + | NoSuchThing | OtherError + | PermissionDenied | ProtocolError + | ResourceBusy | ResourceExhausted + | ResourceVanished | SystemError + | TimeExpired | UnsatisfiedConstraints + | UnsupportedOperation + | EOF +#endif + + +-- "errno" type +-- ------------ + +-- Haskell representation for "errno" values +-- +newtype Errno = Errno CInt + +instance Eq Errno where + errno1@(Errno no1) == errno2@(Errno no2) + | isValidErrno errno1 && isValidErrno errno2 = no1 == no2 + | otherwise = False + +-- common "errno" symbols +-- +e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, + eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, + eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, + eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, + eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, + eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, + eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, + eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, + eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, + eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, + ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, + eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, + 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 +-- configure +-- +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 +-- +isValidErrno :: Errno -> Bool +-- +-- the configure script sets all invalid "errno"s to 0 +-- +isValidErrno (Errno errno) = errno /= 0 + + +-- access to the current thread's "errno" value +-- -------------------------------------------- + +-- yield the current thread's "errno" value +-- +getErrno :: IO Errno +getErrno = liftM Errno (peek _errno) + + +-- throw current "errno" value +-- --------------------------- + +-- the common case: throw an IO error based on a textual description +-- of the error location and the current thread's "errno" value +-- +throwErrno :: String -> IO a +throwErrno loc = + do + errno <- getErrno + ioError (errnoToIOError loc errno Nothing Nothing) + + +-- guards for IO operations that may fail +-- -------------------------------------- + +-- guard an IO operation and throw an "errno" based exception of the result +-- value of the IO operation meets the given predicate +-- +throwErrnoIf :: (a -> Bool) -> String -> IO a -> IO a +throwErrnoIf pred loc f = + do + res <- f + if pred res then throwErrno loc else return res + +-- as `throwErrnoIf', but discards the result +-- +throwErrnoIf_ :: (a -> Bool) -> String -> IO a -> IO () +throwErrnoIf_ pred loc f = void $ throwErrnoIf pred loc f + +-- as `throwErrnoIf', but retries interrupted IO operations (ie, those whose +-- flag `EINTR') +-- +throwErrnoIfRetry :: (a -> Bool) -> String -> IO a -> IO a +throwErrnoIfRetry pred loc f = + do + res <- f + if pred res + then do + err <- getErrno + if err == eINTR + then throwErrnoIfRetry pred loc f + else throwErrno loc + else return res + +-- as `throwErrnoIfRetry', but discards the result +-- +throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO () +throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f + +-- throws "errno" if a result of "-1" is returned +-- +throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a +throwErrnoIfMinus1 = throwErrnoIf (== -1) + +-- as `throwErrnoIfMinus1', but discards the result +-- +throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO () +throwErrnoIfMinus1_ = throwErrnoIf_ (== -1) + +-- throws "errno" if a result of "-1" is returned, but retries in case of an +-- interrupted operation +-- +throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a +throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1) + +-- as `throwErrnoIfMinus1', but discards the result +-- +throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO () +throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1) + +-- throws "errno" if a result of a NULL pointer is returned +-- +throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +throwErrnoIfNull = throwErrnoIf (== nullPtr) + +-- throws "errno" if a result of a NULL pointer is returned, but retries in +-- case of an interrupted operation +-- +throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a) +throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr) + + +-- conversion of an "errno" value into IO error +-- -------------------------------------------- + +-- convert a location string, an "errno" value, an optional handle, +-- and an optional filename into a matching IO error +-- +errnoToIOError :: String -> Errno -> Maybe Handle -> Maybe String -> IOError +errnoToIOError loc errno@(Errno no) maybeHdl maybeName = +#if __GLASGOW_HASKELL__ + IOException (IOError maybeHdl errType loc str maybeName) +#else + userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName) +#endif + where + (errType, str) + | no == 0 = (OtherError, + "no error") + | errno == e2BIG = (ResourceExhausted, + "argument list too long") + | errno == eACCES = (PermissionDenied, + "inadequate access permission") + | errno == eADDRINUSE = (ResourceBusy, + "address already in use") + | errno == eADDRNOTAVAIL = (UnsupportedOperation, + "address not available") + | errno == eADV = (OtherError, + "RFS advertise error") + | errno == eAFNOSUPPORT = (UnsupportedOperation, + "address family not supported by " ++ + "protocol family") + -- no multiline strings with cpp + | errno == eAGAIN = (ResourceExhausted, + "insufficient resources") + | errno == eALREADY = (AlreadyExists, + "operation already in progress") + | errno == eBADF = (OtherError, + "internal error (EBADF)") + | errno == eBADMSG = (InappropriateType, + "next message has wrong type") + | errno == eBADRPC = (OtherError, + "invalid RPC request or response") + | errno == eBUSY = (ResourceBusy, + "device busy") + | errno == eCHILD = (NoSuchThing, + "no child processes") + | errno == eCOMM = (ResourceVanished, + "no virtual circuit could be found") + | errno == eCONNABORTED = (OtherError, + "aborted connection") + | errno == eCONNREFUSED = (NoSuchThing, + "no listener on remote host") + | errno == eCONNRESET = (ResourceVanished, + "connection reset by peer") + | errno == eDEADLK = (ResourceBusy, + "resource deadlock avoided") + | errno == eDESTADDRREQ = (InvalidArgument, + "destination address required") + | errno == eDIRTY = (UnsatisfiedConstraints, + "file system dirty") + | errno == eDOM = (InvalidArgument, + "argument too large") + | errno == eDQUOT = (PermissionDenied, + "quota exceeded") + | errno == eEXIST = (AlreadyExists, + "file already exists") + | errno == eFAULT = (OtherError, + "internal error (EFAULT)") + | errno == eFBIG = (PermissionDenied, + "file too large") + | errno == eFTYPE = (InappropriateType, + "inappropriate NFS file type or format") + | errno == eHOSTDOWN = (NoSuchThing, + "destination host down") + | errno == eHOSTUNREACH = (NoSuchThing, + "remote host is unreachable") + | errno == eIDRM = (ResourceVanished, + "IPC identifier removed") + | errno == eILSEQ = (InvalidArgument, + "invalid wide character") + | errno == eINPROGRESS = (AlreadyExists, + "operation now in progress") + | errno == eINTR = (Interrupted, + "interrupted system call") + | errno == eINVAL = (InvalidArgument, + "invalid argument") + | errno == eIO = (HardwareFault, + "unknown I/O fault") + | errno == eISCONN = (AlreadyExists, + "socket is already connected") + | errno == eISDIR = (InappropriateType, + "file is a directory") + | errno == eLOOP = (InvalidArgument, + "too many symbolic links") + | errno == eMFILE = (ResourceExhausted, + "process file table full") + | errno == eMLINK = (ResourceExhausted, + "too many links") + | errno == eMSGSIZE = (ResourceExhausted, + "message too long") + | errno == eMULTIHOP = (UnsupportedOperation, + "multi-hop RFS request") + | errno == eNAMETOOLONG = (InvalidArgument, + "filename too long") + | errno == eNETDOWN = (ResourceVanished, + "network is down") + | errno == eNETRESET = (ResourceVanished, + "remote host rebooted; connection lost") + | errno == eNETUNREACH = (NoSuchThing, + "remote network is unreachable") + | errno == eNFILE = (ResourceExhausted, + "system file table full") + | errno == eNOBUFS = (ResourceExhausted, + "no buffer space available") + | errno == eNODATA = (NoSuchThing, + "no message on the stream head read " ++ + "queue") + -- no multiline strings with cpp + | errno == eNODEV = (NoSuchThing, + "no such device") + | errno == eNOENT = (NoSuchThing, + "no such file or directory") + | errno == eNOEXEC = (InvalidArgument, + "not an executable file") + | errno == eNOLCK = (ResourceExhausted, + "no file locks available") + | errno == eNOLINK = (ResourceVanished, + "RFS link has been severed") + | errno == eNOMEM = (ResourceExhausted, + "not enough virtual memory") + | errno == eNOMSG = (NoSuchThing, + "no message of desired type") + | errno == eNONET = (NoSuchThing, + "host is not on a network") + | errno == eNOPROTOOPT = (UnsupportedOperation, + "operation not supported by protocol") + | errno == eNOSPC = (ResourceExhausted, + "no space left on device") + | errno == eNOSR = (ResourceExhausted, + "out of stream resources") + | errno == eNOSTR = (InvalidArgument, + "not a stream device") + | errno == eNOSYS = (UnsupportedOperation, + "function not implemented") + | errno == eNOTBLK = (InvalidArgument, + "not a block device") + | errno == eNOTCONN = (InvalidArgument, + "socket is not connected") + | errno == eNOTDIR = (InappropriateType, + "not a directory") + | errno == eNOTEMPTY = (UnsatisfiedConstraints, + "directory not empty") + | errno == eNOTSOCK = (InvalidArgument, + "not a socket") + | errno == eNOTTY = (IllegalOperation, + "inappropriate ioctl for device") + | errno == eNXIO = (NoSuchThing, + "no such device or address") + | errno == eOPNOTSUPP = (UnsupportedOperation, + "operation not supported on socket") + | errno == ePERM = (PermissionDenied, + "privileged operation") + | errno == ePFNOSUPPORT = (UnsupportedOperation, + "protocol family not supported") + | errno == ePIPE = (ResourceVanished, + "broken pipe") + | errno == ePROCLIM = (PermissionDenied, + "too many processes") + | errno == ePROCUNAVAIL = (UnsupportedOperation, + "unimplemented RPC procedure") + | errno == ePROGMISMATCH = (ProtocolError, + "unsupported RPC program version") + | errno == ePROGUNAVAIL = (UnsupportedOperation, + "RPC program unavailable") + | errno == ePROTO = (ProtocolError, + "error in streams protocol") + | errno == ePROTONOSUPPORT = (ProtocolError, + "protocol not supported") + | errno == ePROTOTYPE = (ProtocolError, + "wrong protocol for socket") + | errno == eRANGE = (UnsupportedOperation, + "result too large") + | errno == eREMCHG = (ResourceVanished, + "remote address changed") + | errno == eREMOTE = (IllegalOperation, + "too many levels of remote in path") + | errno == eROFS = (PermissionDenied, + "read-only file system") + | errno == eRPCMISMATCH = (ProtocolError, + "RPC version is wrong") + | errno == eRREMOTE = (IllegalOperation, + "object is remote") + | errno == eSHUTDOWN = (IllegalOperation, + "can't send after socket shutdown") + | errno == eSOCKTNOSUPPORT = (UnsupportedOperation, + "socket type not supported") + | errno == eSPIPE = (UnsupportedOperation, + "can't seek on a pipe") + | errno == eSRCH = (NoSuchThing, + "no such process") + | errno == eSRMNT = (UnsatisfiedConstraints, + "RFS resources still mounted by " ++ + "remote host(s)") + -- no multiline strings with cpp + | errno == eSTALE = (ResourceVanished, + "stale NFS file handle") + | errno == eTIME = (TimeExpired, + "timer expired") + | errno == eTIMEDOUT = (TimeExpired, + "connection timed out") + | errno == eTOOMANYREFS = (ResourceExhausted, + "too many references; can't splice") + | errno == eTXTBSY = (ResourceBusy, + "text file in-use") + | errno == eUSERS = (ResourceExhausted, + "quota table full") + | errno == eWOULDBLOCK = (OtherError, + "operation would block") + | errno == eXDEV = (UnsupportedOperation, + "can't make a cross-device link") + | otherwise = (OtherError, + "unexpected error (error code: " + ++ show no ++")") + +foreign label "errno" _errno :: Ptr CInt + -- FIXME: this routine should eventually be provided by the Haskell runtime + -- and guarantee that the "errno" of the last operation performed by + -- the current thread is returned +\end{code} diff --git a/ghc/lib/std/PrelCString.lhs b/ghc/lib/std/PrelCString.lhs new file mode 100644 index 0000000..753416f --- /dev/null +++ b/ghc/lib/std/PrelCString.lhs @@ -0,0 +1,143 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelCString.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +% +% (c) The FFI task force, 2000 +% + +Utilities for primitive marshaling + +\begin{code} +module PrelCString where + +import Monad + +import PrelMarshalArray +import PrelMarshalAlloc +import PrelException +import PrelPtr +import PrelStorable +import PrelCTypes +import PrelCTypesISO +import PrelInt +import PrelByteArr +import PrelPack +import PrelBase + +#ifdef __GLASGOW_HASKELL__ +import PrelIOBase hiding (malloc, _malloc) +#endif + +----------------------------------------------------------------------------- +-- Strings + +-- representation of strings in C +-- ------------------------------ + +type CString = Ptr CChar -- conventional NUL terminates strings +type CStringLen = (CString, Int) -- strings with explicit length + + +-- exported functions +-- ------------------ +-- +-- * the following routines apply the default conversion when converting the +-- C-land character encoding into the Haskell-land character encoding +-- +-- ** NOTE: The current implementation doesn't handle conversions yet! ** +-- +-- * the routines using an explicit length tolerate NUL characters in the +-- middle of a string +-- + +-- marshal a NUL terminated C string into a Haskell string +-- +peekCString :: CString -> IO String +peekCString cp = liftM cCharsToChars $ peekArray0 nUL cp + +-- marshal a C string with explicit length into a Haskell string +-- +peekCStringLen :: CStringLen -> IO String +peekCStringLen (cp, len) = liftM cCharsToChars $ peekArray len cp + +-- marshal a Haskell string into a NUL terminated C strings +-- +-- * the Haskell string may *not* contain any NUL characters +-- +-- * new storage is allocated for the C string and must be explicitly freed +-- +newCString :: String -> IO CString +newCString = newArray0 nUL . charsToCChars + +-- marshal a Haskell string into a C string (ie, character array) with +-- explicit length information +-- +-- * new storage is allocated for the C string and must be explicitly freed +-- +newCStringLen :: String -> IO CStringLen +newCStringLen str = liftM (pairLength str) $ newArray (charsToCChars str) + +-- marshal a Haskell string into a NUL terminated C strings using temporary +-- storage +-- +-- * the Haskell string may *not* contain any NUL characters +-- +-- * see the lifetime constraints of `MarshalAlloc.alloca' +-- +withCString :: String -> (CString -> IO a) -> IO a +withCString = withArray0 nUL . charsToCChars + +-- marshal a Haskell string into a NUL terminated C strings using temporary +-- storage +-- +-- * the Haskell string may *not* contain any NUL characters +-- +-- * see the lifetime constraints of `MarshalAlloc.alloca' +-- +withCStringLen :: String -> (CStringLen -> IO a) -> IO a +withCStringLen str act = withArray (charsToCChars str) $ act . pairLength str + +-- auxilliary definitions +-- ---------------------- + +-- C's end of string character +-- +nUL :: CChar +nUL = castCharToCChar '\0' + +-- pair a C string with the length of the given Haskell string +-- +pairLength :: String -> CString -> CStringLen +pairLength = flip (,) . length + +-- cast [CChar] to [Char] +-- +cCharsToChars :: [CChar] -> [Char] +cCharsToChars = map castCCharToChar + +-- cast [Char] to [CChar] +-- +charsToCChars :: [Char] -> [CChar] +charsToCChars = map castCharToCChar + +castCCharToChar :: CChar -> Char +-- castCCharToChar ch = chr (fromIntegral (fromIntegral ch :: Word8)) +-- The above produces horrible code. Word and Int modules really +-- should be cleaned up... Here is an ugly but fast version: +castCCharToChar ch = case fromIntegral (fromIntegral ch :: Int32) of + I# i# -> C# (chr# (word2Int# (int2Word# i# `and#` int2Word# 0xFF#))) + +castCharToCChar :: Char -> CChar +castCharToCChar ch = fromIntegral (ord ch) + + +-- unsafe CStrings +-- --------------- + +#if __GLASGOW_HASKELL__ +newtype UnsafeCString = UnsafeCString (ByteArray Int) +withUnsafeCString s f = f (UnsafeCString (packString s)) +#else +newtype UnsafeCString = UnsafeCString (Ptr CChar) +withUnsafeCString s f = withCString s (\p -> f (UnsafeCString p)) +#endif +\end{code} diff --git a/ghc/lib/std/PrelCTypes.lhs b/ghc/lib/std/PrelCTypes.lhs new file mode 100644 index 0000000..8335fc9 --- /dev/null +++ b/ghc/lib/std/PrelCTypes.lhs @@ -0,0 +1,81 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelCTypes.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +% +% (c) The FFI task force, 2000 +% + +A mapping of C types to corresponding Haskell types. A cool hack... + +#include "cbits/CTypes.h" + +\begin{code} +module PrelCTypes + ( -- Integral types, instances of: Eq, Ord, Num, Read, Show, Enum, + -- Typeable, Storable, Bounded, Real, Integral, Bits + CChar(..), CSChar(..), CUChar(..) + , CShort(..), CUShort(..), CInt(..), CUInt(..) + , CLong(..), CULong(..), CLLong(..), CULLong(..) + + -- Floating types, instances of: Eq, Ord, Num, Read, Show, Enum, + -- Typeable, Storable, Real, Fractional, Floating, RealFrac, RealFloat + , CFloat(..), CDouble(..), CLDouble(..) + ) where +\end{code} + +\begin{code} +import PrelBase ( unsafeCoerce# ) +import PrelReal ( Integral(toInt) ) +import PrelNum ( Num(fromInt) ) +import PrelBits ( Bits(..) ) +import PrelInt ( Int8, Int16, Int32, Int64 ) +import PrelWord ( Word8, Word16, Word32, Word64 ) +\end{code} + +\begin{code} +INTEGRAL_TYPE(CChar,tyConCChar,"CChar",HTYPE_CHAR) +INTEGRAL_TYPE(CSChar,tyConCSChar,"CSChar",HTYPE_SIGNED_CHAR) +INTEGRAL_TYPE(CUChar,tyConCUChar,"CUChar",HTYPE_UNSIGNED_CHAR) + +INTEGRAL_TYPE(CShort,tyConCShort,"CShort",HTYPE_SHORT) +INTEGRAL_TYPE(CUShort,tyConCUShort,"CUShort",HTYPE_UNSIGNED_SHORT) + +INTEGRAL_TYPE(CInt,tyConCInt,"CInt",HTYPE_INT) +INTEGRAL_TYPE(CUInt,tyConCUInt,"CUInt",HTYPE_UNSIGNED_INT) + +INTEGRAL_TYPE(CLong,tyConCLong,"CLong",HTYPE_LONG) +INTEGRAL_TYPE(CULong,tyConCULong,"CULong",HTYPE_UNSIGNED_LONG) + +INTEGRAL_TYPE(CLLong,tyConCLLong,"CLLong",HTYPE_LONG_LONG) +INTEGRAL_TYPE(CULLong,tyConCULLong,"CULLong",HTYPE_UNSIGNED_LONG_LONG) + +{-# RULES +"fromIntegral/a->CChar" fromIntegral = \x -> CChar (fromIntegral x) +"fromIntegral/a->CSChar" fromIntegral = \x -> CSChar (fromIntegral x) +"fromIntegral/a->CUChar" fromIntegral = \x -> CUChar (fromIntegral x) +"fromIntegral/a->CShort" fromIntegral = \x -> CShort (fromIntegral x) +"fromIntegral/a->CUShort" fromIntegral = \x -> CUShort (fromIntegral x) +"fromIntegral/a->CInt" fromIntegral = \x -> CInt (fromIntegral x) +"fromIntegral/a->CUInt" fromIntegral = \x -> CUInt (fromIntegral x) +"fromIntegral/a->CLong" fromIntegral = \x -> CLong (fromIntegral x) +"fromIntegral/a->CULong" fromIntegral = \x -> CULong (fromIntegral x) +"fromIntegral/a->CLLong" fromIntegral = \x -> CLLong (fromIntegral x) +"fromIntegral/a->CULLong" fromIntegral = \x -> CULLong (fromIntegral x) + +"fromIntegral/CChar->a" fromIntegral = \(CChar x) -> fromIntegral x +"fromIntegral/CSChar->a" fromIntegral = \(CSChar x) -> fromIntegral x +"fromIntegral/CUChar->a" fromIntegral = \(CUChar x) -> fromIntegral x +"fromIntegral/CShort->a" fromIntegral = \(CShort x) -> fromIntegral x +"fromIntegral/CUShort->a" fromIntegral = \(CUShort x) -> fromIntegral x +"fromIntegral/CInt->a" fromIntegral = \(CInt x) -> fromIntegral x +"fromIntegral/CUInt->a" fromIntegral = \(CUInt x) -> fromIntegral x +"fromIntegral/CLong->a" fromIntegral = \(CLong x) -> fromIntegral x +"fromIntegral/CULong->a" fromIntegral = \(CULong x) -> fromIntegral x +"fromIntegral/CLLong->a" fromIntegral = \(CLLong x) -> fromIntegral x +"fromIntegral/CULLong->a" fromIntegral = \(CULLong x) -> fromIntegral x + #-} + +FLOATING_TYPE(CFloat,tyConCFloat,"CFloat",HTYPE_FLOAT) +FLOATING_TYPE(CDouble,tyConCDouble,"CDouble",HTYPE_DOUBLE) +-- HACK: Currently no long double in the FFI, so we simply re-use double +FLOATING_TYPE(CLDouble,tyConCLDouble,"CLDouble",HTYPE_DOUBLE) +\end{code} diff --git a/ghc/lib/std/PrelCTypesISO.lhs b/ghc/lib/std/PrelCTypesISO.lhs new file mode 100644 index 0000000..4fa2aa7 --- /dev/null +++ b/ghc/lib/std/PrelCTypesISO.lhs @@ -0,0 +1,66 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelCTypesISO.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +% +% (c) The FFI task force, 2000 +% + +A mapping of C types defined by the ISO C standard to corresponding Haskell +types. Like CTypes, this is a cool hack... + +#include "cbits/CTypes.h" + +\begin{code} +module PrelCTypesISO + ( -- Integral types, instances of: Eq, Ord, Num, Read, Show, Enum, + -- Typeable, Storable, Bounded, Real, Integral, Bits + CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..) + + -- Numeric types, instances of: Eq, Ord, Num, Read, Show, Enum, + -- Typeable, Storable + , CClock(..), CTime(..), + + , CFile, CFpos, CJmpBuf + ) where +\end{code} + +\begin{code} +import PrelBase ( unsafeCoerce# ) +import PrelReal ( Integral(toInt) ) +import PrelBits ( Bits(..) ) +import PrelNum ( Num(fromInt) ) +import PrelInt ( Int8, Int16, Int32, Int64 ) +import PrelWord ( Word8, Word16, Word32, Word64 ) +\end{code} + +\begin{code} +INTEGRAL_TYPE(CPtrdiff,tyConCPtrdiff,"CPtrdiff",HTYPE_PTRDIFF_T) +INTEGRAL_TYPE(CSize,tyConCSize,"CSize",HTYPE_SIZE_T) +INTEGRAL_TYPE(CWchar,tyConCWchar,"CWchar",HTYPE_WCHAR_T) +INTEGRAL_TYPE(CSigAtomic,tyConCSigAtomic,"CSigAtomic",HTYPE_SIG_ATOMIC_T) + +{-# RULES +"fromIntegral/a->CPtrdiff" fromIntegral = \x -> CPtrdiff (fromIntegral x) +"fromIntegral/a->CSize" fromIntegral = \x -> CSize (fromIntegral x) +"fromIntegral/a->CWchar" fromIntegral = \x -> CWchar (fromIntegral x) +"fromIntegral/a->CSigAtomic" fromIntegral = \x -> CSigAtomic (fromIntegral x) + +"fromIntegral/CPtrdiff->a" fromIntegral = \(CPtrdiff x) -> fromIntegral x +"fromIntegral/CSize->a" fromIntegral = \(CSize x) -> fromIntegral x +"fromIntegral/CWchar->a" fromIntegral = \(CWchar x) -> fromIntegral x +"fromIntegral/CSigAtomic->a" fromIntegral = \(CSigAtomic x) -> fromIntegral x + #-} + +NUMERIC_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T) +NUMERIC_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T) + +-- TODO: Instances. But which...? :-} + +data CFile = CFile + +data CFpos = CFpos + +data CJmpBuf = CJmpBuf + +-- C99 types which are still missing include: +-- intptr_t, uintptr_t, intmax_t, uintmax_t, wint_t, wctrans_t, wctype_t +\end{code} diff --git a/ghc/lib/std/PrelDynamic.lhs b/ghc/lib/std/PrelDynamic.lhs index 02e9104..aabb377 100644 --- a/ghc/lib/std/PrelDynamic.lhs +++ b/ghc/lib/std/PrelDynamic.lhs @@ -1,12 +1,12 @@ % ----------------------------------------------------------------------------- -% $Id: PrelDynamic.lhs,v 1.5 2000/06/30 13:39:35 simonmar Exp $ +% $Id: PrelDynamic.lhs,v 1.6 2001/01/11 17:25:57 simonmar Exp $ % % (c) The University of Glasgow, 1998-2000 % The Dynamic type is used in the Exception type, so we have to have Dynamic visible here. The rest of the operations on Dynamics are -available in exts/Dynamic.lhs. +available in lang/Dynamic.lhs. \begin{code} {-# OPTIONS -fno-implicit-prelude #-} diff --git a/ghc/lib/std/PrelForeign.lhs b/ghc/lib/std/PrelForeign.lhs index f0ea40d..7b74828 100644 --- a/ghc/lib/std/PrelForeign.lhs +++ b/ghc/lib/std/PrelForeign.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelForeign.lhs,v 1.16 2000/12/11 16:56:47 simonmar Exp $ +% $Id: PrelForeign.lhs,v 1.17 2001/01/11 17:25:57 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -9,23 +9,11 @@ \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module PrelForeign ( - module PrelForeign, -#ifndef __PARALLEL_HASKELL__ - ForeignPtr(..), - - -- the rest are deprecated - ForeignObj(..), - makeForeignObj, - mkForeignObj, - writeForeignObj -#endif - ) where +module PrelForeign where import PrelIOBase import PrelBase -import PrelAddr -import PrelWeak ( addForeignFinalizer ) +import PrelPtr \end{code} %********************************************************* @@ -35,79 +23,37 @@ import PrelWeak ( addForeignFinalizer ) %********************************************************* \begin{code} -data ForeignPtr a = ForeignPtr ForeignObj# -instance CCallable (ForeignPtr a) -\end{code} - -%********************************************************* -%* * -\subsection{Type @ForeignObj@ and its operations} -%* * -%********************************************************* - -mkForeignObj and writeForeignObj are the building blocks -for makeForeignObj, they can probably be nuked in the future. - -\begin{code} #ifndef __PARALLEL_HASKELL__ ---instance CCallable ForeignObj ---instance CCallable ForeignObj# - -makeForeignObj :: Addr -> IO () -> IO ForeignObj -makeForeignObj addr finalizer = do - fObj <- mkForeignObj addr - addForeignFinalizer fObj finalizer - return fObj - -mkForeignObj :: Addr -> IO ForeignObj -mkForeignObj (A# obj) = IO ( \ s# -> +newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a) +newForeignPtr p finalizer + = do fObj <- mkForeignPtr p + addForeignPtrFinalizer fObj finalizer + return fObj + +addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO () +addForeignPtrFinalizer (ForeignPtr fo) finalizer = + IO $ \s -> case mkWeak# fo () finalizer s of { (# s1, w #) -> (# s1, () #) } + +mkForeignPtr :: Ptr a -> IO (ForeignPtr a) {- not exported -} +mkForeignPtr (Ptr obj) = IO ( \ s# -> case mkForeignObj# obj s# of - (# s1#, fo# #) -> (# s1#, ForeignObj fo# #) ) - -writeForeignObj :: ForeignObj -> Addr -> IO () -writeForeignObj (ForeignObj fo#) (A# datum#) = IO ( \ s# -> - case writeForeignObj# fo# datum# s# of { s1# -> (# s1#, () #) } ) -#endif /* !__PARALLEL_HASKELL__ */ -\end{code} - -%********************************************************* -%* * -\subsection{Unpacking Foreigns} -%* * -%********************************************************* - -Primitives for converting Foreigns pointing to external -sequence of bytes into a list of @Char@s (a renamed version -of the code above). + (# s1#, fo# #) -> (# s1#, ForeignPtr fo# #) ) -\begin{code} -#ifndef __PARALLEL_HASKELL__ -unpackCStringFO :: ForeignObj -> [Char] -unpackCStringFO (ForeignObj fo#) = unpackCStringFO# fo# +touchForeignPtr :: ForeignPtr a -> IO () +touchForeignPtr (ForeignPtr fo) + = IO $ \s -> case touch# fo s of s -> (# s, () #) -unpackCStringFO# :: ForeignObj# -> [Char] -unpackCStringFO# fo {- ptr. to NUL terminated string-} - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - ch = indexCharOffForeignObj# fo nh +withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +withForeignPtr fo io + = do r <- io (foreignPtrToPtr fo) + touchForeignPtr fo + return r -unpackNBytesFO :: ForeignObj -> Int -> [Char] -unpackNBytesFO (ForeignObj fo) (I# l) = unpackNBytesFO# fo l +foreignPtrToPtr :: ForeignPtr a -> Ptr a +foreignPtrToPtr (ForeignPtr fo) = Ptr (foreignObjToAddr# fo) -unpackNBytesFO# :: ForeignObj# -> Int# -> [Char] - -- This one is called by the compiler to unpack literal strings with NULs in them; rare. -unpackNBytesFO# fo len - = unpack 0# - where - unpack i - | i >=# len = [] - | otherwise = C# ch : unpack (i +# 1#) - where - ch = indexCharOffForeignObj# fo i +castForeignPtr (ForeignPtr a) = ForeignPtr a #endif \end{code} + diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index aea1192..33d208e 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelHandle.lhs,v 1.65 2001/01/11 07:04:16 qrczak Exp $ +% $Id: PrelHandle.lhs,v 1.66 2001/01/11 17:25:57 simonmar Exp $ % % (c) The AQUA Project, Glasgow University, 1994-2000 % @@ -18,7 +18,7 @@ module PrelHandle where import PrelArr import PrelBase -import PrelAddr ( Addr, nullAddr ) +import PrelPtr import PrelByteArr ( ByteArray(..) ) import PrelRead ( Read ) import PrelList ( break ) @@ -28,17 +28,13 @@ import PrelException import PrelEnum import PrelNum ( toBig, Integer(..), Num(..) ) import PrelShow -import PrelAddr ( Addr, nullAddr ) import PrelReal ( toInteger ) import PrelPack ( packString ) -#ifndef __PARALLEL_HASKELL__ -import PrelWeak ( addForeignFinalizer ) -#endif import PrelConc #ifndef __PARALLEL_HASKELL__ -import PrelForeign ( makeForeignObj, mkForeignObj ) +import PrelForeign ( newForeignPtr, mkForeignPtr, addForeignPtrFinalizer ) #endif #endif /* ndef(__HUGS__) */ @@ -49,9 +45,9 @@ import PrelForeign ( makeForeignObj, mkForeignObj ) #endif #ifndef __PARALLEL_HASKELL__ -#define FILE_OBJECT ForeignObj +#define FILE_OBJECT (ForeignPtr ()) #else -#define FILE_OBJECT Addr +#define FILE_OBJECT (Ptr ()) #endif \end{code} @@ -60,10 +56,10 @@ mkBuffer__ :: FILE_OBJECT -> Int -> IO () mkBuffer__ fo sz_in_bytes = do chunk <- case sz_in_bytes of - 0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer. + 0 -> return nullPtr -- this has the effect of overwriting the pointer to the old buffer. _ -> do chunk <- malloc sz_in_bytes - if chunk == nullAddr + if chunk == nullPtr then ioException (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory" Nothing) else return chunk @@ -149,9 +145,9 @@ file object reference. nullFile__ :: FILE_OBJECT nullFile__ = #ifndef __PARALLEL_HASKELL__ - unsafePerformIO (makeForeignObj nullAddr (return ())) + unsafePerformIO (newForeignPtr nullPtr (return ())) #else - nullAddr + nullPtr #endif @@ -194,7 +190,7 @@ foreign import "libHS_cbits" "freeStdFileObject" unsafe foreign import "libHS_cbits" "freeFileObject" unsafe freeFileObject :: FILE_OBJECT -> IO () foreign import "free" unsafe - free :: Addr -> IO () + free :: Ptr a -> IO () \end{code} %********************************************************* @@ -221,10 +217,10 @@ stdout = unsafePerformIO (do (0::Int){-writeable-} -- ConcHask: SAFE, won't block #ifndef __PARALLEL_HASKELL__ - fo <- mkForeignObj fo + fo <- mkForeignPtr fo -- I know this is deprecated, but I couldn't bring myself - -- to move fixIO into the prelude just so I could use makeForeignObj. - -- --SDM + -- to move fixIO into the prelude just so I could use + -- newForeignPtr. --SDM #endif #ifdef __HUGS__ @@ -239,7 +235,7 @@ stdout = unsafePerformIO (do hdl <- newHandle (Handle__ fo WriteHandle bm "stdout" []) #ifndef __PARALLEL_HASKELL__ - addForeignFinalizer fo (stdHandleFinalizer hdl) + addForeignPtrFinalizer fo (stdHandleFinalizer hdl) #endif return hdl @@ -255,7 +251,7 @@ stdin = unsafePerformIO (do (1::Int){-readable-} -- ConcHask: SAFE, won't block #ifndef __PARALLEL_HASKELL__ - fo <- mkForeignObj fo + fo <- mkForeignPtr fo #endif (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size @@ -264,7 +260,7 @@ stdin = unsafePerformIO (do -- that anything buffered on stdout is flushed prior to reading from -- stdin. #ifndef __PARALLEL_HASKELL__ - addForeignFinalizer fo (stdHandleFinalizer hdl) + addForeignPtrFinalizer fo (stdHandleFinalizer hdl) #endif hConnectTerms stdout hdl return hdl @@ -281,14 +277,14 @@ stderr = unsafePerformIO (do (0::Int){-writeable-} -- ConcHask: SAFE, won't block #ifndef __PARALLEL_HASKELL__ - fo <- mkForeignObj fo + fo <- mkForeignPtr fo #endif hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr" []) -- when stderr and stdout are both connected to a terminal, ensure -- that anything buffered on stdout is flushed prior to writing to -- stderr. #ifndef __PARALLEL_HASKELL__ - addForeignFinalizer fo (stdHandleFinalizer hdl) + addForeignPtrFinalizer fo (stdHandleFinalizer hdl) #endif hConnectTo stdout hdl return hdl @@ -321,15 +317,15 @@ openFileEx f m = do fo <- primOpenFile (packString f) (file_mode::Int) (binary::Int) -- ConcHask: SAFE, won't block - if fo /= nullAddr then do + if fo /= nullPtr then do #ifndef __PARALLEL_HASKELL__ - fo <- mkForeignObj fo + fo <- mkForeignPtr fo #endif (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size hdl <- newHandle (Handle__ fo htype bm f []) #ifndef __PARALLEL_HASKELL__ - addForeignFinalizer fo (handleFinalizer hdl) + addForeignPtrFinalizer fo (handleFinalizer hdl) #endif return hdl else do @@ -390,9 +386,9 @@ hClose handle = (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block {- We explicitly close a file object so that we can be told if there were any errors. Note that after @hClose@ - has been performed, the ForeignObj embedded in the Handle + has been performed, the ForeignPtr embedded in the Handle is still lying around in the heap, so care is taken - to avoid closing the file object when the ForeignObj + to avoid closing the file object when the ForeignPtr is finalized. (we overwrite the file ptr in the underlying FileObject with a NULL as part of closeFile()) -} @@ -884,7 +880,7 @@ this as an extension: \begin{code} -- in one go, read file into an externally allocated buffer. -slurpFile :: FilePath -> IO (Addr, Int) +slurpFile :: FilePath -> IO (Ptr (), Int) slurpFile fname = do handle <- openFile fname ReadMode sz <- hFileSize handle @@ -893,7 +889,7 @@ slurpFile fname = do else do let sz_i = fromInteger sz chunk <- malloc sz_i - if chunk == nullAddr + if chunk == nullPtr then do hClose handle constructErrorAndFail "slurpFile" @@ -993,10 +989,10 @@ reportError bombOut str = do return () foreign import ccall "addrOf_ErrorHdrHook" unsafe - addrOf_ErrorHdrHook :: Addr + addrOf_ErrorHdrHook :: Ptr () foreign import ccall "writeErrString__" unsafe - writeErrString :: Addr -> ByteArray Int -> Int -> IO () + writeErrString :: Ptr () -> ByteArray Int -> Int -> IO () -- SUP: Are the hooks allowed to re-enter Haskell land? If yes, remove the unsafe below. foreign import ccall "stackOverflow" unsafe @@ -1216,13 +1212,13 @@ foreign import "libHS_cbits" "writeFileObject" unsafe foreign import "libHS_cbits" "filePutc" unsafe filePutc :: FILE_OBJECT -> Char -> IO Int{-ret code-} foreign import "libHS_cbits" "write_" unsafe - write_ :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-} + write_ :: FILE_OBJECT -> Ptr () -> Int -> IO Int{-ret code-} foreign import "libHS_cbits" "getBufStart" unsafe - getBufStart :: FILE_OBJECT -> Int -> IO Addr + getBufStart :: FILE_OBJECT -> Int -> IO (Ptr ()) foreign import "libHS_cbits" "getWriteableBuf" unsafe - getWriteableBuf :: FILE_OBJECT -> IO Addr + getWriteableBuf :: FILE_OBJECT -> IO (Ptr ()) foreign import "libHS_cbits" "getBuf" unsafe - getBuf :: FILE_OBJECT -> IO Addr + getBuf :: FILE_OBJECT -> IO (Ptr ()) foreign import "libHS_cbits" "getBufWPtr" unsafe getBufWPtr :: FILE_OBJECT -> IO Int foreign import "libHS_cbits" "setBufWPtr" unsafe @@ -1260,7 +1256,7 @@ foreign import "libHS_cbits" "setConnectedTo" unsafe foreign import "libHS_cbits" "ungetChar" unsafe ungetChar :: FILE_OBJECT -> Char -> IO Int{-ret code-} foreign import "libHS_cbits" "readChunk" unsafe - readChunk :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-} + readChunk :: FILE_OBJECT -> Ptr a -> Int -> Int -> IO Int{-ret code-} foreign import "libHS_cbits" "getFileFd" unsafe getFileFd :: FILE_OBJECT -> IO Int{-fd-} #ifdef __HUGS__ @@ -1280,17 +1276,17 @@ foreign import "libHS_cbits" "getConnFileFd" unsafe foreign import "libHS_cbits" "getLock" unsafe getLock :: Int{-Fd-} -> Int{-exclusive-} -> IO Int{-return code-} foreign import "libHS_cbits" "openStdFile" unsafe - openStdFile :: Int{-fd-} -> Int{-Readable?-} -> IO Addr{-file obj-} + openStdFile :: Int{-fd-} + -> Int{-Readable?-} + -> IO (Ptr ()){-file object-} foreign import "libHS_cbits" "openFile" unsafe primOpenFile :: ByteArray Int{-CString-} -> Int{-How-} -> Int{-Binary-} - -> IO Addr {-file obj-} + -> IO (Ptr ()){-file object-} foreign import "libHS_cbits" "const_BUFSIZ" unsafe const_BUFSIZ :: Int foreign import "libHS_cbits" "setBinaryMode__" unsafe setBinaryMode :: FILE_OBJECT -> Int -> IO Int \end{code} - - diff --git a/ghc/lib/std/PrelIO.lhs b/ghc/lib/std/PrelIO.lhs index b78c697..0a149b5 100644 --- a/ghc/lib/std/PrelIO.lhs +++ b/ghc/lib/std/PrelIO.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelIO.lhs,v 1.17 2001/01/11 07:04:16 qrczak Exp $ +% $Id: PrelIO.lhs,v 1.18 2001/01/11 17:25:57 simonmar Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -26,13 +26,18 @@ import PrelNum import PrelRead ( Read(..), readIO ) import PrelShow import PrelMaybe ( Maybe(..) ) -import PrelAddr ( Addr(..), nullAddr, plusAddr ) +import PrelPtr import PrelList ( concat, reverse, null ) import PrelPack ( unpackNBytesST, unpackNBytesAccST ) import PrelException ( ioError, catch, catchException, throw ) import PrelConc -\end{code} +#ifndef __PARALLEL_HASKELL__ +#define FILE_OBJECT (ForeignPtr ()) +#else +#define FILE_OBJECT (Ptr ()) +#endif +\end{code} %********************************************************* %* * @@ -155,7 +160,7 @@ hGetLine h = do (\fo -> readLine fo) (\fo bytes -> do buf <- getBufStart fo bytes - eol <- readCharOffAddr buf (bytes-1) + eol <- readCharOffPtr buf (bytes-1) xs <- if (eol == '\n') then stToIO (unpackNBytesST buf (bytes-1)) else stToIO (unpackNBytesST buf bytes) @@ -196,7 +201,7 @@ hGetLineUnBuffered h = do return (c:s) -readCharOffAddr (A# a) (I# i) +readCharOffPtr (Ptr a) (I# i) = IO $ \s -> case readCharOffAddr# a i s of { (# s,x #) -> (# s, C# x #) } \end{code} @@ -261,15 +266,9 @@ so each these lazy read functions are pulled on, they have to check whether the handle has indeed been closed. \begin{code} -#ifndef __PARALLEL_HASKELL__ -lazyReadBlock :: Handle -> ForeignObj -> IO String -lazyReadLine :: Handle -> ForeignObj -> IO String -lazyReadChar :: Handle -> ForeignObj -> IO String -#else -lazyReadBlock :: Handle -> Addr -> IO String -lazyReadLine :: Handle -> Addr -> IO String -lazyReadChar :: Handle -> Addr -> IO String -#endif +lazyReadBlock :: Handle -> FILE_OBJECT -> IO String +lazyReadLine :: Handle -> FILE_OBJECT -> IO String +lazyReadChar :: Handle -> FILE_OBJECT -> IO String lazyReadBlock handle fo = do buf <- getBufStart fo 0 @@ -369,27 +368,27 @@ hPutStr handle str = do -- malloced buffers is one way around this, but we really ought to -- be able to handle it with exception handlers/block/unblock etc. -getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Addr, Int)) +getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Ptr (), Int)) getBuffer handle_ = do let bufs = haBuffers__ handle_ fo = haFO__ handle_ mode = haBufferMode__ handle_ sz <- getBufSize fo case mode of - NoBuffering -> return (handle_, (mode, nullAddr, 0)) + NoBuffering -> return (handle_, (mode, nullPtr, 0)) _ -> case bufs of [] -> do buf <- malloc sz return (handle_, (mode, buf, sz)) (b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz)) -freeBuffer :: Handle__ -> Addr -> Int -> IO Handle__ +freeBuffer :: Handle__ -> Ptr () -> Int -> IO Handle__ freeBuffer handle_ buf sz = do fo_sz <- getBufSize (haFO__ handle_) if (sz /= fo_sz) then do { free buf; return handle_ } else do { return handle_{ haBuffers__ = buf : haBuffers__ handle_ } } -swapBuffers :: Handle__ -> Addr -> Int -> IO Handle__ +swapBuffers :: Handle__ -> Ptr () -> Int -> IO Handle__ swapBuffers handle_ buf sz = do let fo = haFO__ handle_ fo_buf <- getBuf fo @@ -419,7 +418,7 @@ swapBuffers handle_ buf sz = do commitAndReleaseBuffer :: Handle -- handle to commit to - -> Addr -> Int -- address and size (in bytes) of buffer + -> Ptr () -> Int -- address and size (in bytes) of buffer -> Int -- number of bytes of data in buffer -> Bool -- flush the handle afterward? -> IO () @@ -480,7 +479,7 @@ commitAndReleaseBuffer hdl@(Handle h) buf sz count flush = do -- not flushing, and there's enough room in the buffer: -- just copy the data in and update bufWPtr. - else do memcpy (plusAddr fo_buf fo_wptr) buf count + else do memcpy (plusPtr fo_buf fo_wptr) buf count setBufWPtr fo (fo_wptr + count) handle_ <- freeBuffer handle_ buf sz ok handle_ @@ -507,7 +506,7 @@ commitAndReleaseBuffer hdl@(Handle h) buf sz count flush = do commitBuffer :: Handle -- handle to commit to - -> Addr -> Int -- address and size (in bytes) of buffer + -> Ptr () -> Int -- address and size (in bytes) of buffer -> Int -- number of bytes of data in buffer -> Bool -- flush the handle afterward? -> IO () @@ -534,7 +533,7 @@ commitBuffer handle buf sz count flush = do if (rc < 0) then constructErrorAndFail "commitBuffer" else return () - else do memcpy (plusAddr fo_buf new_wptr) buf count + else do memcpy (plusPtr fo_buf new_wptr) buf count setBufWPtr fo (new_wptr + count) return () @@ -552,7 +551,7 @@ checkedCommitBuffer handle buf sz count flush (\e -> do withHandle__ handle (\h_ -> freeBuffer h_ buf sz) throw e) -foreign import "memcpy" unsafe memcpy :: Addr -> Addr -> Int -> IO () +foreign import "memcpy" unsafe memcpy :: Ptr () -> Ptr () -> Int -> IO () \end{code} Going across the border between Haskell and C is relatively costly, @@ -567,7 +566,7 @@ before passing the external write routine a pointer to the buffer. #warning delayed update of buffer disnae work with killThread #endif -writeLines :: Handle -> Addr -> Int -> String -> IO () +writeLines :: Handle -> Ptr () -> Int -> String -> IO () writeLines handle buf bufLen s = let shoveString :: Int -> [Char] -> IO () @@ -590,7 +589,7 @@ writeLines handle buf bufLen s = #else /* ndef __HUGS__ */ -writeLines :: Handle -> Addr -> Int -> String -> IO () +writeLines :: Handle -> Ptr () -> Int -> String -> IO () writeLines hdl buf len@(I# bufLen) s = let shoveString :: Int# -> [Char] -> IO () @@ -614,7 +613,7 @@ writeLines hdl buf len@(I# bufLen) s = #endif /* ndef __HUGS__ */ #ifdef __HUGS__ -writeBlocks :: Handle -> Addr -> Int -> String -> IO () +writeBlocks :: Handle -> Ptr () -> Int -> String -> IO () writeBlocks hdl buf bufLen s = let shoveString :: Int -> [Char] -> IO () @@ -636,7 +635,7 @@ writeBlocks hdl buf bufLen s = #else /* ndef __HUGS__ */ -writeBlocks :: Handle -> Addr -> Int -> String -> IO () +writeBlocks :: Handle -> Ptr () -> Int -> String -> IO () writeBlocks hdl buf len@(I# bufLen) s = let shoveString :: Int# -> [Char] -> IO () @@ -656,8 +655,8 @@ writeBlocks hdl buf len@(I# bufLen) s = in shoveString 0# s -write_char :: Addr -> Int# -> Char# -> IO () -write_char (A# buf#) n# c# = +write_char :: Ptr () -> Int# -> Char# -> IO () +write_char (Ptr buf#) n# c# = IO $ \ s# -> case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #) #endif /* ndef __HUGS__ */ diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 1efaee6..02aad74 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelIOBase.lhs,v 1.31 2001/01/11 07:04:16 qrczak Exp $ +% $Id: PrelIOBase.lhs,v 1.32 2001/01/11 17:25:57 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -23,10 +23,10 @@ import PrelST import PrelBase import PrelNum ( fromInteger ) -- Integer literals import PrelMaybe ( Maybe(..) ) -import PrelAddr ( Addr(..), nullAddr ) import PrelShow import PrelList import PrelDynamic +import PrelPtr import PrelPack ( unpackCString ) #if !defined(__CONCURRENT_HASKELL__) @@ -41,9 +41,10 @@ import PrelArr ( MutableVar, readVar ) #endif #ifndef __PARALLEL_HASKELL__ -#define FILE_OBJECT ForeignObj +#define FILE_OBJECT (ForeignPtr ()) #else -#define FILE_OBJECT Addr +#define FILE_OBJECT (Ptr ()) + #endif \end{code} @@ -170,20 +171,21 @@ instance Eq (MVar a) where (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# {- - Double sigh - ForeignObj is needed here too to break a cycle. + Double sigh - ForeignPtr is needed here too to break a cycle. -} -data ForeignObj = ForeignObj ForeignObj# -- another one -instance CCallable ForeignObj +data ForeignPtr a = ForeignPtr ForeignObj# +instance CCallable (ForeignPtr a) -eqForeignObj :: ForeignObj -> ForeignObj -> Bool -eqForeignObj mp1 mp2 - = unsafePerformIO (primEqForeignObj mp1 mp2) /= (0::Int) +eqForeignPtr :: ForeignPtr a -> ForeignPtr a -> Bool +eqForeignPtr mp1 mp2 + = unsafePerformIO (primEqForeignPtr mp1 mp2) /= (0::Int) -foreign import "eqForeignObj" unsafe primEqForeignObj :: ForeignObj -> ForeignObj -> IO Int +foreign import "eqForeignObj" unsafe + primEqForeignPtr :: ForeignPtr a -> ForeignPtr a -> IO Int -instance Eq ForeignObj where - p == q = eqForeignObj p q - p /= q = not (eqForeignObj p q) +instance Eq (ForeignPtr a) where + p == q = eqForeignPtr p q + p /= q = not (eqForeignPtr p q) #endif /* ndef __HUGS__ */ #if defined(__CONCURRENT_HASKELL__) @@ -215,7 +217,7 @@ data Handle__ haType__ :: Handle__Type, haBufferMode__ :: BufferMode, haFilePath__ :: FilePath, - haBuffers__ :: [Addr] + haBuffers__ :: [Ptr ()] } {- @@ -354,24 +356,25 @@ data BufferMode Foreign import declarations to helper routines: \begin{code} -foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO Addr +foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO (Ptr ()) foreign import "libHS_cbits" "getErrNo__" unsafe getErrNo__ :: IO Int foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int -malloc :: Int -> IO Addr +-- ToDo: use mallocBytes from PrelMarshal? +malloc :: Int -> IO (Ptr ()) malloc sz = do a <- _malloc sz - if (a == nullAddr) + if (a == nullPtr) then ioException (IOError Nothing ResourceExhausted "malloc" "out of memory" Nothing) else return a -foreign import "malloc" unsafe _malloc :: Int -> IO Addr +foreign import "malloc" unsafe _malloc :: Int -> IO (Ptr ()) foreign import "libHS_cbits" "getBufSize" unsafe getBufSize :: FILE_OBJECT -> IO Int foreign import "libHS_cbits" "setBuf" unsafe - setBuf :: FILE_OBJECT -> Addr -> Int -> IO () + setBuf :: FILE_OBJECT -> Ptr () -> Int -> IO () \end{code} diff --git a/ghc/lib/std/PrelInt.lhs b/ghc/lib/std/PrelInt.lhs index 9597f15..1143e0c 100644 --- a/ghc/lib/std/PrelInt.lhs +++ b/ghc/lib/std/PrelInt.lhs @@ -1,7 +1,7 @@ % % (c) The University of Glasgow, 2000 % -\section[Int]{Module @PrelInt@} +\section[PrelInt]{Module @PrelInt@} \begin{code} {-# OPTIONS -monly-3-regs #-} @@ -44,34 +44,16 @@ module PrelInt , int64ToInt16 -- :: Int64 -> Int16 , int64ToInt32 -- :: Int64 -> Int32 - -- The "official" place to get these from is Addr, importing - -- them from Int is a non-standard thing to do. - -- SUP: deprecated in the new FFI, subsumed by the Storable class - , indexInt8OffAddr - , indexInt16OffAddr - , indexInt32OffAddr - , indexInt64OffAddr - - , readInt8OffAddr - , readInt16OffAddr - , readInt32OffAddr - , readInt64OffAddr - - , writeInt8OffAddr - , writeInt16OffAddr - , writeInt32OffAddr - , writeInt64OffAddr - -- internal stuff , intToInt8#, i8ToInt#, intToInt16#, i16ToInt#, intToInt32#, i32ToInt#, , intToInt64#, plusInt64#, minusInt64#, negateInt64# + ) where import PrelWord +import PrelBits import PrelArr import PrelRead -import PrelIOBase -import PrelAddr import PrelReal import PrelNum import PrelBase @@ -297,6 +279,40 @@ instance Read Int8 where instance Show Int8 where showsPrec p i8 = showsPrec p (int8ToInt i8) +binop8 :: (Int32 -> Int32 -> a) -> (Int8 -> Int8 -> a) +binop8 op x y = int8ToInt32 x `op` int8ToInt32 y + +instance Bits Int8 where + (I8# x) .&. (I8# y) = I8# (word2Int# ((int2Word# x) `and#` (int2Word# y))) + (I8# x) .|. (I8# y) = I8# (word2Int# ((int2Word# x) `or#` (int2Word# y))) + (I8# x) `xor` (I8# y) = I8# (word2Int# ((int2Word# x) `xor#` (int2Word# y))) + complement (I8# x) = I8# (word2Int# ((int2Word# x) `xor#` (int2Word# 0xff#))) + shift (I8# x) i@(I# i#) + | i > 0 = I8# (intToInt8# (iShiftL# (i8ToInt# x) i#)) + | otherwise = I8# (intToInt8# (iShiftRA# (i8ToInt# x) (negateInt# i#))) + i8@(I8# x) `rotate` (I# i) + | i ==# 0# = i8 + | i ># 0# = + I8# (intToInt8# ( word2Int# ( + (int2Word# (iShiftL# (i8ToInt# x) i')) + `or#` + (int2Word# (iShiftRA# (word2Int# ( + (int2Word# x) `and#` + (int2Word# (0x100# -# pow2# i2)))) + i2))))) + | otherwise = rotate i8 (I# (8# +# i)) + where + i' = word2Int# (int2Word# i `and#` int2Word# 7#) + i2 = 8# -# i' + bitSize _ = 8 + isSigned _ = True + +pow2# :: Int# -> Int# +pow2# x# = iShiftL# 1# x# + +pow2_64# :: Int# -> Int64# +pow2_64# x# = word64ToInt64# (shiftL64# (wordToWord64# (int2Word# 1#)) x#) + -- ----------------------------------------------------------------------------- -- Int16 -- ----------------------------------------------------------------------------- @@ -407,6 +423,34 @@ instance Read Int16 where instance Show Int16 where showsPrec p i16 = showsPrec p (int16ToInt i16) + +binop16 :: (Int32 -> Int32 -> a) -> (Int16 -> Int16 -> a) +binop16 op x y = int16ToInt32 x `op` int16ToInt32 y + +instance Bits Int16 where + (I16# x) .&. (I16# y) = I16# (word2Int# ((int2Word# x) `and#` (int2Word# y))) + (I16# x) .|. (I16# y) = I16# (word2Int# ((int2Word# x) `or#` (int2Word# y))) + (I16# x) `xor` (I16# y) = I16# (word2Int# ((int2Word# x) `xor#` (int2Word# y))) + complement (I16# x) = I16# (word2Int# ((int2Word# x) `xor#` (int2Word# 0xffff#))) + shift (I16# x) i@(I# i#) + | i > 0 = I16# (intToInt16# (iShiftL# (i16ToInt# x) i#)) + | otherwise = I16# (intToInt16# (iShiftRA# (i16ToInt# x) (negateInt# i#))) + i16@(I16# x) `rotate` (I# i) + | i ==# 0# = i16 + | i ># 0# = + I16# (intToInt16# (word2Int# ( + (int2Word# (iShiftL# (i16ToInt# x) i')) + `or#` + (int2Word# (iShiftRA# ( word2Int# ( + (int2Word# x) `and#` (int2Word# (0x100# -# pow2# i2)))) + i2))))) + | otherwise = rotate i16 (I# (16# +# i)) + where + i' = word2Int# (int2Word# i `and#` int2Word# 15#) + i2 = 16# -# i' + bitSize _ = 16 + isSigned _ = True + -- ----------------------------------------------------------------------------- -- Int32 -- ----------------------------------------------------------------------------- @@ -532,13 +576,44 @@ instance Read Int32 where instance Show Int32 where showsPrec p i32 = showsPrec p (int32ToInt i32) +instance Bits Int32 where + (I32# x) .&. (I32# y) = I32# (word2Int# ((int2Word# x) `and#` (int2Word# y))) + (I32# x) .|. (I32# y) = I32# (word2Int# ((int2Word# x) `or#` (int2Word# y))) + (I32# x) `xor` (I32# y) = I32# (word2Int# ((int2Word# x) `xor#` (int2Word# y))) +#if WORD_SIZE_IN_BYTES > 4 + complement (I32# x) = I32# (word2Int# ((int2Word# x) `xor#` (int2Word# 0xffffffff#))) +#else + complement (I32# x) = I32# (word2Int# ((int2Word# x) `xor#` (int2Word# (negateInt# 1#)))) +#endif + shift (I32# x) i@(I# i#) + | i > 0 = I32# (intToInt32# (iShiftL# (i32ToInt# x) i#)) + | otherwise = I32# (intToInt32# (iShiftRA# (i32ToInt# x) (negateInt# i#))) + i32@(I32# x) `rotate` (I# i) + | i ==# 0# = i32 + | i ># 0# = + -- ( (x<>i2) + I32# (intToInt32# ( word2Int# ( + (int2Word# (iShiftL# (i32ToInt# x) i')) + `or#` + (int2Word# (iShiftRA# (word2Int# ( + (int2Word# x) + `and#` + (int2Word# (maxBound# -# pow2# i2 +# 1#)))) + i2))))) + | otherwise = rotate i32 (I# (32# +# i)) + where + i' = word2Int# (int2Word# i `and#` int2Word# 31#) + i2 = 32# -# i' + (I32# maxBound#) = maxBound + bitSize _ = 32 + isSigned _ = True + -- ----------------------------------------------------------------------------- -- Int64 -- ----------------------------------------------------------------------------- #if WORD_SIZE_IN_BYTES == 8 - ---data Int64 = I64# Int# +data Int64 = I64# Int# int32ToInt64 (I32# i#) = I64# i# @@ -603,7 +678,7 @@ int64ToInt (I64# i#) = I# i# #else --assume: support for long-longs ---data Int64 = I64 Int64# deriving (Eq, Ord, Bounded) +data Int64 = I64# Int64# int32ToInt64 (I32# i#) = I64# (intToInt64# i#) int64ToInt32 (I64# i#) = I32# (int64ToInt# i#) @@ -680,70 +755,49 @@ quotInt64 (I64# x) (I64# y) = I64# (x `quotInt64#` y) intToInt64 (I# i#) = I64# (intToInt64# i#) int64ToInt (I64# i#) = I# (int64ToInt# i#) --- Word64# primop wrappers: +-- Int64# primop wrappers: ltInt64# :: Int64# -> Int64# -> Bool -ltInt64# x# y# = stg_ltInt64 x# y# /= 0 +ltInt64# x# y# = stg_ltInt64 x# y# /=# 0# leInt64# :: Int64# -> Int64# -> Bool -leInt64# x# y# = stg_leInt64 x# y# /= 0 +leInt64# x# y# = stg_leInt64 x# y# /=# 0# eqInt64# :: Int64# -> Int64# -> Bool -eqInt64# x# y# = stg_eqInt64 x# y# /= 0 +eqInt64# x# y# = stg_eqInt64 x# y# /=# 0# neInt64# :: Int64# -> Int64# -> Bool -neInt64# x# y# = stg_neInt64 x# y# /= 0 +neInt64# x# y# = stg_neInt64 x# y# /=# 0# geInt64# :: Int64# -> Int64# -> Bool -geInt64# x# y# = stg_geInt64 x# y# /= 0 +geInt64# x# y# = stg_geInt64 x# y# /=# 0# gtInt64# :: Int64# -> Int64# -> Bool -gtInt64# x# y# = stg_gtInt64 x# y# /= 0 - -plusInt64# :: Int64# -> Int64# -> Int64# -plusInt64# a# b# = case stg_plusInt64 a# b# of { I64# i# -> i# } - -minusInt64# :: Int64# -> Int64# -> Int64# -minusInt64# a# b# = case stg_minusInt64 a# b# of { I64# i# -> i# } - -timesInt64# :: Int64# -> Int64# -> Int64# -timesInt64# a# b# = case stg_timesInt64 a# b# of { I64# i# -> i# } - -quotInt64# :: Int64# -> Int64# -> Int64# -quotInt64# a# b# = case stg_quotInt64 a# b# of { I64# i# -> i# } - -remInt64# :: Int64# -> Int64# -> Int64# -remInt64# a# b# = case stg_remInt64 a# b# of { I64# i# -> i# } - -negateInt64# :: Int64# -> Int64# -negateInt64# a# = case stg_negateInt64 a# of { I64# i# -> i# } - -int64ToInt# :: Int64# -> Int# -int64ToInt# i64# = case stg_int64ToInt i64# of { I# i# -> i# } - -intToInt64# :: Int# -> Int64# -intToInt64# i# = case stg_intToInt64 i# of { I64# i64# -> i64# } - -foreign import "stg_intToInt64" unsafe stg_intToInt64 :: Int# -> Int64 -foreign import "stg_int64ToInt" unsafe stg_int64ToInt :: Int64# -> Int -foreign import "stg_negateInt64" unsafe stg_negateInt64 :: Int64# -> Int64 -foreign import "stg_remInt64" unsafe stg_remInt64 :: Int64# -> Int64# -> Int64 -foreign import "stg_quotInt64" unsafe stg_quotInt64 :: Int64# -> Int64# -> Int64 -foreign import "stg_timesInt64" unsafe stg_timesInt64 :: Int64# -> Int64# -> Int64 -foreign import "stg_minusInt64" unsafe stg_minusInt64 :: Int64# -> Int64# -> Int64 -foreign import "stg_plusInt64" unsafe stg_plusInt64 :: Int64# -> Int64# -> Int64 -foreign import "stg_gtInt64" unsafe stg_gtInt64 :: Int64# -> Int64# -> Int -foreign import "stg_geInt64" unsafe stg_geInt64 :: Int64# -> Int64# -> Int -foreign import "stg_neInt64" unsafe stg_neInt64 :: Int64# -> Int64# -> Int -foreign import "stg_eqInt64" unsafe stg_eqInt64 :: Int64# -> Int64# -> Int -foreign import "stg_leInt64" unsafe stg_leInt64 :: Int64# -> Int64# -> Int -foreign import "stg_ltInt64" unsafe stg_ltInt64 :: Int64# -> Int64# -> Int +gtInt64# x# y# = stg_gtInt64 x# y# /=# 0# + +foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64# +foreign import "stg_int64ToInt" unsafe int64ToInt# :: Int64# -> Int# +foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64# +foreign import "stg_remInt64" unsafe remInt64# :: Int64# -> Int64# -> Int64# +foreign import "stg_quotInt64" unsafe quotInt64# :: Int64# -> Int64# -> Int64# +foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64# +foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64# +foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64# +foreign import "stg_gtInt64" unsafe stg_gtInt64 :: Int64# -> Int64# -> Int# +foreign import "stg_geInt64" unsafe stg_geInt64 :: Int64# -> Int64# -> Int# +foreign import "stg_neInt64" unsafe stg_neInt64 :: Int64# -> Int64# -> Int# +foreign import "stg_eqInt64" unsafe stg_eqInt64 :: Int64# -> Int64# -> Int# +foreign import "stg_leInt64" unsafe stg_leInt64 :: Int64# -> Int64# -> Int# +foreign import "stg_ltInt64" unsafe stg_ltInt64 :: Int64# -> Int64# -> Int# #endif -- -- Code that's independent of Int64 rep. -- +instance CCallable Int64 +instance CReturnable Int64 + instance Enum Int64 where succ i | i == maxBound = succError "Int64" @@ -787,74 +841,78 @@ instance Ix Int64 where instance Real Int64 where toRational x = toInteger x % 1 --- --------------------------------------------------------------------------- --- Reading/writing Ints from memory --- --------------------------------------------------------------------------- - -indexInt8OffAddr :: Addr -> Int -> Int8 -indexInt8OffAddr (A# a#) (I# i#) = I8# (indexInt8OffAddr# a# i#) - -indexInt16OffAddr :: Addr -> Int -> Int16 -indexInt16OffAddr (A# a#) (I# i#) = I16# (indexInt16OffAddr# a# i#) - -indexInt32OffAddr :: Addr -> Int -> Int32 -indexInt32OffAddr (A# a#) (I# i#) = I32# (indexInt32OffAddr# a# i#) - -indexInt64OffAddr :: Addr -> Int -> Int64 -#if WORD_SIZE_IN_BYTES==8 -indexInt64OffAddr (A# a#) (I# i#) = I64# (indexIntOffAddr# a# i#) -#else -indexInt64OffAddr (A# a#) (I# i#) = I64# (indexInt64OffAddr# a# i#) -#endif - - -readInt8OffAddr :: Addr -> Int -> IO Int8 -readInt8OffAddr (A# a) (I# i) - = IO $ \s -> case readInt8OffAddr# a i s of (# s, w #) -> (# s, I8# w #) - -readInt16OffAddr :: Addr -> Int -> IO Int16 -readInt16OffAddr (A# a) (I# i) - = IO $ \s -> case readInt16OffAddr# a i s of (# s, w #) -> (# s, I16# w #) - -readInt32OffAddr :: Addr -> Int -> IO Int32 -readInt32OffAddr (A# a) (I# i) - = IO $ \s -> case readInt32OffAddr# a i s of (# s, w #) -> (# s, I32# w #) - -readInt64OffAddr :: Addr -> Int -> IO Int64 #if WORD_SIZE_IN_BYTES == 8 -readInt64OffAddr (A# a) (I# i) - = IO $ \s -> case readIntOffAddr# a i s of (# s, w #) -> (# s, I64# w #) -#else -readInt64OffAddr (A# a) (I# i) - = IO $ \s -> case readInt64OffAddr# a i s of (# s, w #) -> (# s, I64# w #) -#endif - - -writeInt8OffAddr :: Addr -> Int -> Int8 -> IO () -writeInt8OffAddr (A# a#) (I# i#) (I8# w#) = IO $ \ s# -> - case (writeInt8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) +instance Bits Int64 where + (I64# x) .&. (I64# y) = I64# (word2Int# ((int2Word# x) `and#` (int2Word# y))) + (I64# x) .|. (I64# y) = I64# (word2Int# ((int2Word# x) `or#` (int2Word# y))) + (I64# x) `xor` (I64# y) = I64# (word2Int# ((int2Word# x) `xor#` (int2Word# y))) + complement (I64# x) = I64# (negateInt# x) + shift (I64# x) i@(I# i#) + | i > 0 = I64# (iShiftL# x i#) + | otherwise = I64# (iShiftRA# x (negateInt# i#)) + i64@(I64# x) `rotate` (I# i) + | i ==# 0# = i64 + | i ># 0# = + -- ( (x<>i2) ) + I64# (word2Int# ( + (int2Word# (iShiftL# x i')) + `or#` + (int2Word# (iShiftRA# (word2Int# ( + (int2Word# x) + `and#` + (int2Word# (maxBound# -# pow2# i2 +# 1#)))) + i2)))) + | otherwise = rotate i64 (I# (64# +# i)) + where + i' = word2Int# (int2Word# i `and#` int2Word# 63#) + i2 = 64# -# i' + (I64# maxBound#) = maxBound + bitSize _ = 64 + isSigned _ = True + +#else /* WORD_SIZE_IN_BYTES != 8 */ + +instance Bits Int64 where + (I64# x) .&. (I64# y) = I64# (word64ToInt64# ((int64ToWord64# x) `and64#` (int64ToWord64# y))) + (I64# x) .|. (I64# y) = I64# (word64ToInt64# ((int64ToWord64# x) `or64#` (int64ToWord64# y))) + (I64# x) `xor` (I64# y) = I64# (word64ToInt64# ((int64ToWord64# x) `xor64#` (int64ToWord64# y))) + complement (I64# x) = I64# (negateInt64# x) + shift (I64# x) i@(I# i#) + | i > 0 = I64# (iShiftL64# x i#) + | otherwise = I64# (iShiftRA64# x (negateInt# i#)) + i64@(I64# x) `rotate` (I# i) + | i ==# 0# = i64 + | i ># 0# = + -- ( (x<>i2) ) + I64# (word64ToInt64# ( + (int64ToWord64# (iShiftL64# x i')) `or64#` + (int64ToWord64# (iShiftRA64# (word64ToInt64# ((int64ToWord64# x) `and64#` + (int64ToWord64# (maxBound# `minusInt64#` (pow2_64# i2 `plusInt64#` (intToInt64# 1#)))))) + i2)))) + | otherwise = rotate i64 (I# (64# +# i)) + where + i' = word2Int# (int2Word# i `and#` int2Word# 63#) + i2 = 64# -# i' + (I64# maxBound#) = maxBound + bitSize _ = 64 + isSigned _ = True + +foreign import "stg_not64" unsafe not64# :: Word64# -> Word64# +foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64# +foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64# +foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64# +foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64# +foreign import "stg_iShiftRA64" unsafe iShiftRA64# :: Int64# -> Int# -> Int64# +foreign import "stg_iShiftRL64" unsafe iShiftRL64# :: Int64# -> Int# -> Int64# +foreign import "stg_iShiftL64" unsafe iShiftL64# :: Int64# -> Int# -> Int64# +foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64# -writeInt16OffAddr :: Addr -> Int -> Int16 -> IO () -writeInt16OffAddr (A# a#) (I# i#) (I16# w#) = IO $ \ s# -> - case (writeInt16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) - -writeInt32OffAddr :: Addr -> Int -> Int32 -> IO () -writeInt32OffAddr (A# a#) (I# i#) (I32# w#) = IO $ \ s# -> - case (writeInt32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) - -writeInt64OffAddr :: Addr -> Int -> Int64 -> IO () -#if WORD_SIZE_IN_BYTES == 8 -writeInt64OffAddr (A# a#) (I# i#) (I64# w#) = IO $ \ s# -> - case (writeIntOffAddr# a# i# w# s#) of s2# -> (# s2#, () #) -#else -writeInt64OffAddr (A# a#) (I# i#) (I64# w#) = IO $ \ s# -> - case (writeInt64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) #endif -\end{code} -Miscellaneous Utilities +-- --------------------------------------------------------------------------- +-- Miscellaneous Utilities +-- --------------------------------------------------------------------------- -\begin{code} absReal :: (Ord a, Num a) => a -> a absReal x | x >= 0 = x | otherwise = -x diff --git a/ghc/lib/std/PrelMarshalAlloc.lhs b/ghc/lib/std/PrelMarshalAlloc.lhs new file mode 100644 index 0000000..12c42fa --- /dev/null +++ b/ghc/lib/std/PrelMarshalAlloc.lhs @@ -0,0 +1,105 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelMarshalAlloc.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +% +% (c) The FFI task force, 2000 +% + +Marshalling support: basic routines for memory allocation + +\begin{code} +module PrelMarshalAlloc ( + malloc, -- :: Storable a => IO (Ptr a) + mallocBytes, -- :: Int -> IO (Ptr a) + + alloca, -- :: Storable a => (Ptr a -> IO b) -> IO b + allocaBytes, -- :: Int -> (Ptr a -> IO b) -> IO b + + reallocBytes, -- :: Ptr a -> Int -> IO (Ptr a) + + free -- :: Ptr a -> IO () +) where + +import PrelException ( bracket ) +import PrelPtr ( Ptr, nullPtr ) +import PrelStorable ( Storable(sizeOf) ) +import PrelCTypesISO ( CSize ) + +#ifdef __GLASGOW_HASKELL__ +import PrelIOBase hiding (malloc, _malloc) +#endif + + +-- exported functions +-- ------------------ + +-- allocate space for storable type +-- +malloc :: Storable a => IO (Ptr a) +malloc = doMalloc undefined + where + doMalloc :: Storable a => a -> IO (Ptr a) + doMalloc dummy = mallocBytes (sizeOf dummy) + +-- allocate given number of bytes of storage +-- +mallocBytes :: Int -> IO (Ptr a) +mallocBytes size = failWhenNULL "malloc" (_malloc (fromIntegral size)) + +-- temporarily allocate space for a storable type +-- +-- * the pointer passed as an argument to the function must *not* escape from +-- this function; in other words, in `alloca f' the allocated storage must +-- not be used after `f' returns +-- +alloca :: Storable a => (Ptr a -> IO b) -> IO b +alloca = doAlloca undefined + where + doAlloca :: Storable a => a -> (Ptr a -> IO b) -> IO b + doAlloca dummy = allocaBytes (sizeOf dummy) + +-- temporarily allocate the given number of bytes of storage +-- +-- * the pointer passed as an argument to the function must *not* escape from +-- this function; in other words, in `allocaBytes n f' the allocated storage +-- must not be used after `f' returns +-- +allocaBytes :: Int -> (Ptr a -> IO b) -> IO b +allocaBytes size = bracket (mallocBytes size) free + +-- adjust a malloc'ed storage area to the given size +-- +reallocBytes :: Ptr a -> Int -> IO (Ptr a) +reallocBytes ptr size = + failWhenNULL "realloc" (_realloc ptr (fromIntegral size)) + +-- free malloc'ed storage +-- +free :: Ptr a -> IO () +free = _free + + +-- auxilliary routines +-- ------------------- + +-- asserts that the pointer returned from the action in the second argument is +-- non-null +-- +failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a) +failWhenNULL name f = do + addr <- f + if addr == nullPtr +#ifdef __GLASGOW_HASKELL__ + then ioException (IOError Nothing ResourceExhausted name + "out of memory" Nothing) +#else + then ioError (userError (name++": out of memory")) +#endif + else return addr + +-- basic C routines needed for memory allocation +-- +foreign import "malloc" unsafe _malloc :: CSize -> IO (Ptr a) +foreign import "realloc" unsafe _realloc :: Ptr a -> CSize -> IO (Ptr a) +foreign import "free" unsafe _free :: Ptr a -> IO () + +\end{code} diff --git a/ghc/lib/std/PrelMarshalArray.lhs b/ghc/lib/std/PrelMarshalArray.lhs new file mode 100644 index 0000000..a856441 --- /dev/null +++ b/ghc/lib/std/PrelMarshalArray.lhs @@ -0,0 +1,205 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelMarshalArray.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +% +% (c) The FFI task force, 2000 +% + +Marshalling support: routines allocating, storing, and retrieving Haskell +lists that are represented as arrays in the foreign language + +\begin{code} +module PrelMarshalArray ( + + -- allocation + -- + mallocArray, -- :: Storable a => Int -> IO (Ptr a) + mallocArray0, -- :: Storable a => Int -> IO (Ptr a) + + allocaArray, -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b + allocaArray0, -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b + + reallocArray, -- :: Storable a => Ptr a -> Int -> IO (Ptr a) + reallocArray0, -- :: Storable a => Ptr a -> Int -> IO (Ptr a) + + -- marshalling + -- + peekArray, -- :: Storable a => Int -> Ptr a -> IO [a] + peekArray0, -- :: (Storable a, Eq a) => a -> Ptr a -> IO [a] + + pokeArray, -- :: Storable a => Ptr a -> [a] -> IO () + pokeArray0, -- :: Storable a => a -> Ptr a -> [a] -> IO () + + -- combined allocation and marshalling + -- + newArray, -- :: Storable a => [a] -> IO (Ptr a) + newArray0, -- :: Storable a => a -> [a] -> IO (Ptr a) + + withArray, -- :: Storable a => [a] -> (Ptr a -> IO b) -> IO b + withArray0, -- :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b + + -- copying (argument order: destination, source) + -- + copyArray, -- :: Storable a => Ptr a -> Ptr a -> Int -> IO () + moveArray, -- :: Storable a => Ptr a -> Ptr a -> Int -> IO () + + -- indexing + -- + advancePtr -- :: Storable a => Ptr a -> Int -> Ptr a +) where + +import Monad (zipWithM_) + +import PrelPtr (Ptr, plusPtr) +import PrelStorable (Storable(sizeOf, peekElemOff, pokeElemOff)) +import PrelMarshalAlloc (mallocBytes, allocaBytes, reallocBytes) +import PrelMarshalUtils (copyBytes, moveBytes) + + +-- allocation +-- ---------- + +-- allocate storage for the given number of elements of a storable type +-- +mallocArray :: Storable a => Int -> IO (Ptr a) +mallocArray = doMalloc undefined + where + doMalloc :: Storable a => a -> Int -> IO (Ptr a) + doMalloc dummy size = mallocBytes (size * sizeOf dummy) + +-- like `mallocArray', but add an extra element to signal the end of the array +-- +mallocArray0 :: Storable a => Int -> IO (Ptr a) +mallocArray0 size = mallocArray (size + 1) + +-- temporarily allocate space for the given number of elements +-- +-- * see `MarshalAlloc.alloca' for the storage lifetime constraints +-- +allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b +allocaArray = doAlloca undefined + where + doAlloca :: Storable a => a -> Int -> (Ptr a -> IO b) -> IO b + doAlloca dummy size = allocaBytes (size * sizeOf dummy) + +-- like `allocaArray', but add an extra element to signal the end of the array +-- +allocaArray0 :: Storable a => Int -> (Ptr a -> IO b) -> IO b +allocaArray0 size = allocaArray (size + 1) + +-- adjust the size of an array +-- +reallocArray :: Storable a => Ptr a -> Int -> IO (Ptr a) +reallocArray = doRealloc undefined + where + doRealloc :: Storable a => a -> Ptr a -> Int -> IO (Ptr a) + doRealloc dummy ptr size = reallocBytes ptr (size * sizeOf dummy) + +-- adjust the size of an array while adding an element for the end marker +-- +reallocArray0 :: Storable a => Ptr a -> Int -> IO (Ptr a) +reallocArray0 ptr size = reallocArray ptr (size + 1) + + +-- marshalling +-- ----------- + +-- convert an array of given length into a Haskell list +-- +peekArray :: Storable a => Int -> Ptr a -> IO [a] +peekArray size ptr = mapM (peekElemOff ptr) [0..size-1] + +-- convert an array terminated by the given end marker into a Haskell list +-- +peekArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO [a] +peekArray0 marker ptr = loop 0 + where + loop i = do + val <- peekElemOff ptr i + if val == marker then return [] else do + rest <- loop (i+1) + return (val:rest) + +-- write the list elements consecutive into memory +-- +pokeArray :: Storable a => Ptr a -> [a] -> IO () +pokeArray ptr vals = zipWithM_ (pokeElemOff ptr) [0..] vals + +-- write the list elements consecutive into memory and terminate them with the +-- given marker element +-- +pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO () +pokeArray0 marker ptr vals = do + pokeArray ptr vals + pokeElemOff ptr (length vals) marker + + +-- combined allocation and marshalling +-- ----------------------------------- + +-- write a list of storable elements into a newly allocated, consecutive +-- sequence of storable values +-- +newArray :: Storable a => [a] -> IO (Ptr a) +newArray vals = do + ptr <- mallocArray (length vals) + pokeArray ptr vals + return ptr + +-- write a list of storable elements into a newly allocated, consecutive +-- sequence of storable values, where the end is fixed by the given end maker +-- +newArray0 :: Storable a => a -> [a] -> IO (Ptr a) +newArray0 marker vals = do + ptr <- mallocArray0 (length vals) + pokeArray0 marker ptr vals + return ptr + +-- temporarily store a list of storable values in memory +-- +withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b +withArray vals f = allocaArray (length vals) $ \ptr -> do + pokeArray ptr vals + f ptr + +-- `like withArray', but a terminator indicates where the array ends +-- +withArray0 :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b +withArray0 marker vals f = allocaArray0 (length vals) $ \ptr -> do + pokeArray0 marker ptr vals + f ptr + + +-- copying +-- ------- + +-- copies the given number of elements from the second array (source) into the +-- first array (destination); the copied areas may *not* overlap +-- +copyArray :: Storable a => Ptr a -> Ptr a -> Int -> IO () +copyArray = doCopy undefined + where + doCopy :: Storable a => a -> Ptr a -> Ptr a -> Int -> IO () + doCopy dummy dest src size = copyBytes dest src (size * sizeOf dummy) + +-- copies the given number of elements from the second array (source) into the +-- first array (destination); the copied areas *may* overlap +-- +moveArray :: Storable a => Ptr a -> Ptr a -> Int -> IO () +moveArray = doMove undefined + where + doMove :: Storable a => a -> Ptr a -> Ptr a -> Int -> IO () + doMove dummy dest src size = moveBytes dest src (size * sizeOf dummy) + + +-- indexing +-- -------- + +-- advance a pointer into an array by the given number of elements +-- +advancePtr :: Storable a => Ptr a -> Int -> Ptr a +advancePtr = doAdvance undefined + where + doAdvance :: Storable a => a -> Ptr a -> Int -> Ptr a + doAdvance dummy ptr i = ptr `plusPtr` (i * sizeOf dummy) + +\end{code} diff --git a/ghc/lib/std/PrelMarshalError.lhs b/ghc/lib/std/PrelMarshalError.lhs new file mode 100644 index 0000000..e7bccae --- /dev/null +++ b/ghc/lib/std/PrelMarshalError.lhs @@ -0,0 +1,71 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelMarshalError.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +% +% (c) The FFI task force, 2000 +% + +Marshalling support: Handling of common error conditions + +\begin{code} + +module PrelMarshalError ( + + -- throw an exception on specific return values + -- + throwIf, -- :: (a -> Bool) -> (a -> String) -> IO a -> IO a + throwIf_, -- :: (a -> Bool) -> (a -> String) -> IO a -> IO () + throwIfNeg, -- :: (Ord a, Num a) + -- => (a -> String) -> IO a -> IO a + throwIfNeg_, -- :: (Ord a, Num a) + -- => (a -> String) -> IO a -> IO () + throwIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a) + + -- discard return value + -- + void -- IO a -> IO () +) where + +import PrelPtr +import PrelBase + +-- exported functions +-- ------------------ + +-- guard an IO operation and throw an exception if the result meets the given +-- predicate +-- +-- * the second argument computes an error message from the result of the IO +-- operation +-- +throwIf :: (a -> Bool) -> (a -> String) -> IO a -> IO a +throwIf pred msgfct act = + do + res <- act + (if pred res then ioError . userError . msgfct else return) res + +-- like `throwIf', but discarding the result +-- +throwIf_ :: (a -> Bool) -> (a -> String) -> IO a -> IO () +throwIf_ pred msgfct act = void $ throwIf pred msgfct act + +-- guards against negative result values +-- +throwIfNeg :: (Ord a, Num a) => (a -> String) -> IO a -> IO a +throwIfNeg = throwIf (< 0) + +-- like `throwIfNeg', but discarding the result +-- +throwIfNeg_ :: (Ord a, Num a) => (a -> String) -> IO a -> IO () +throwIfNeg_ = throwIf_ (< 0) + +-- guards against null pointers +-- +throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +throwIfNull = throwIf (== nullPtr) . const + +-- discard the return value of an IO action +-- +void :: IO a -> IO () +void act = act >> return () + +\end{code} diff --git a/ghc/lib/std/PrelMarshalUtils.lhs b/ghc/lib/std/PrelMarshalUtils.lhs new file mode 100644 index 0000000..3ca37dc --- /dev/null +++ b/ghc/lib/std/PrelMarshalUtils.lhs @@ -0,0 +1,152 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelMarshalUtils.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +% +% (c) The FFI task force, 2000 +% + +Utilities for primitive marshaling + +\begin{code} +module PrelMarshalUtils ( + + -- combined allocation and marshalling + -- + withObject, -- :: Storable a => a -> (Ptr a -> IO b) -> IO b + {- FIXME: should be `with' -} + new, -- :: Storable a => a -> IO (Ptr a) + + -- marshalling of Boolean values (non-zero corresponds to `True') + -- + fromBool, -- :: Num a => Bool -> a + toBool, -- :: Num a => a -> Bool + + -- marshalling of Maybe values + -- + maybeNew, -- :: ( a -> IO (Ptr a)) + -- -> (Maybe a -> IO (Ptr a)) + maybeWith, -- :: ( a -> (Ptr b -> IO c) -> IO c) + -- -> (Maybe a -> (Ptr b -> IO c) -> IO c) + maybePeek, -- :: (Ptr a -> IO b ) + -- -> (Ptr a -> IO (Maybe b)) + + -- marshalling lists of storable objects + -- + withMany, -- :: (a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res + + -- Haskellish interface to memcpy and memmove + -- (argument order: destination, source) + -- + copyBytes, -- :: Ptr a -> Ptr a -> Int -> IO () + moveBytes -- :: Ptr a -> Ptr a -> Int -> IO () +) where + +import Monad ( liftM ) + +import PrelPtr ( Ptr, nullPtr ) +import PrelStorable ( Storable (poke) ) +import PrelCTypesISO ( CSize ) +import PrelMarshalAlloc ( malloc, alloca ) + + +-- combined allocation and marshalling +-- ----------------------------------- + +-- allocate storage for a value and marshal it into this storage +-- +new :: Storable a => a -> IO (Ptr a) +new val = + do + ptr <- malloc + poke ptr val + return ptr + +-- allocate temporary storage for a value and marshal it into this storage +-- +-- * see the life time constraints imposed by `alloca' +-- +{- FIXME: should be called `with' -} +withObject :: Storable a => a -> (Ptr a -> IO b) -> IO b +withObject val f = alloca $ \ptr -> do poke ptr val; f ptr + + +-- marshalling of Boolean values (non-zero corresponds to `True') +-- ----------------------------- + +-- convert a Haskell Boolean to its numeric representation +-- +fromBool :: Num a => Bool -> a +fromBool False = 0 +fromBool True = 1 + +-- convert a Boolean in numeric representation to a Haskell value +-- +toBool :: Num a => a -> Bool +toBool = (/= 0) + + +-- marshalling of Maybe values +-- --------------------------- + +-- allocate storage and marshall a storable value wrapped into a `Maybe' +-- +-- * the `nullPtr' is used to represent `Nothing' +-- +maybeNew :: ( a -> IO (Ptr a)) + -> (Maybe a -> IO (Ptr a)) +maybeNew = maybe (return nullPtr) + +-- converts a withXXX combinator into one marshalling a value wrapped into a +-- `Maybe' +-- +maybeWith :: ( a -> (Ptr b -> IO c) -> IO c) + -> (Maybe a -> (Ptr b -> IO c) -> IO c) +maybeWith = maybe ($ nullPtr) + +-- convert a peek combinator into a one returning `Nothing' if applied to a +-- `nullPtr' +-- +maybePeek :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) +maybePeek peek ptr | ptr == nullPtr = return Nothing + | otherwise = liftM Just $ peek ptr + + +-- marshalling lists of storable objects +-- ------------------------------------- + +-- replicates a withXXX combinator over a list of objects, yielding a list of +-- marshalled objects +-- +withMany :: (a -> (b -> res) -> res) -- withXXX combinator for one object + -> [a] -- storable objects + -> ([b] -> res) -- action on list of marshalled obj.s + -> res +withMany _ [] f = f [] +withMany withFoo (x:xs) f = withFoo x $ \x' -> + withMany withFoo xs (\xs' -> f (x':xs')) + + +-- Haskellish interface to memcpy and memmove +-- ------------------------------------------ + +-- copies the given number of bytes from the second area (source) into the +-- first (destination); the copied areas may *not* overlap +-- +copyBytes :: Ptr a -> Ptr a -> Int -> IO () +copyBytes dest src size = memcpy dest src (fromIntegral size) + +-- copies the given number of elements from the second area (source) into the +-- first (destination); the copied areas *may* overlap +-- +moveBytes :: Ptr a -> Ptr a -> Int -> IO () +moveBytes dest src size = memmove dest src (fromIntegral size) + + +-- auxilliary routines +-- ------------------- + +-- basic C routines needed for memory copying +-- +foreign import unsafe memcpy :: Ptr a -> Ptr a -> CSize -> IO () +foreign import unsafe memmove :: Ptr a -> Ptr a -> CSize -> IO () + +\end{code} diff --git a/ghc/lib/std/PrelPack.lhs b/ghc/lib/std/PrelPack.lhs index 5359012..65fed7d 100644 --- a/ghc/lib/std/PrelPack.lhs +++ b/ghc/lib/std/PrelPack.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelPack.lhs,v 1.15 2000/12/12 12:19:58 simonmar Exp $ +% $Id: PrelPack.lhs,v 1.16 2001/01/11 17:25:57 simonmar Exp $ % % (c) The University of Glasgow, 1997-2000 % @@ -25,11 +25,12 @@ module PrelPack packStringST, -- :: [Char] -> ST s (ByteArray Int) packNBytesST, -- :: Int -> [Char] -> ST s (ByteArray Int) - unpackCString, -- :: Addr -> [Char] - unpackCStringST, -- :: Addr -> ST s [Char] - unpackNBytes, -- :: Addr -> Int -> [Char] - unpackNBytesST, -- :: Addr -> Int -> ST s [Char] - unpackNBytesAccST, -- :: Addr -> Int -> [Char] -> ST s [Char] + unpackCString, -- :: Ptr a -> [Char] + unpackCStringST, -- :: Ptr a -> ST s [Char] + unpackNBytes, -- :: Ptr a -> Int -> [Char] + unpackNBytesST, -- :: Ptr a -> Int -> ST s [Char] + unpackNBytesAccST, -- :: Ptr a -> Int -> [Char] -> ST s [Char] + unpackNBytesAccST#,-- :: Ptr a -> Int -> [Char] -> ST s [Char] unpackCString#, -- :: Addr# -> [Char] ** unpackNBytes#, -- :: Addr# -> Int# -> [Char] ** unpackNBytesST#, -- :: Addr# -> Int# -> ST s [Char] @@ -56,13 +57,13 @@ import PrelList ( length ) import PrelST import PrelNum import PrelByteArr -import PrelAddr +import PrelPtr \end{code} %********************************************************* %* * -\subsection{Unpacking Addrs} +\subsection{Unpacking Ptrs} %* * %********************************************************* @@ -70,17 +71,17 @@ Primitives for converting Addrs pointing to external sequence of bytes into a list of @Char@s: \begin{code} -unpackCString :: Addr -> [Char] -unpackCString a@(A# addr) - | a == nullAddr = [] +unpackCString :: Ptr a -> [Char] +unpackCString a@(Ptr addr) + | a == nullPtr = [] | otherwise = unpackCString# addr -unpackNBytes :: Addr -> Int -> [Char] -unpackNBytes (A# addr) (I# l) = unpackNBytes# addr l +unpackNBytes :: Ptr a -> Int -> [Char] +unpackNBytes (Ptr addr) (I# l) = unpackNBytes# addr l -unpackCStringST :: Addr{- ptr. to NUL terminated string-} -> ST s [Char] -unpackCStringST a@(A# addr) - | a == nullAddr = return [] +unpackCStringST :: Ptr a{- ptr. to NUL terminated string-} -> ST s [Char] +unpackCStringST a@(Ptr addr) + | a == nullPtr = return [] | otherwise = unpack 0# where unpack nh @@ -91,11 +92,11 @@ unpackCStringST a@(A# addr) where ch = indexCharOffAddr# addr nh -unpackNBytesST :: Addr -> Int -> ST s [Char] -unpackNBytesST (A# addr) (I# l) = unpackNBytesAccST# addr l [] +unpackNBytesST :: Ptr a -> Int -> ST s [Char] +unpackNBytesST (Ptr addr) (I# l) = unpackNBytesAccST# addr l [] -unpackNBytesAccST :: Addr -> Int -> [Char] -> ST s [Char] -unpackNBytesAccST (A# addr) (I# l) rest = unpackNBytesAccST# addr l rest +unpackNBytesAccST :: Ptr a -> Int -> [Char] -> ST s [Char] +unpackNBytesAccST (Ptr addr) (I# l) rest = unpackNBytesAccST# addr l rest unpackNBytesST# :: Addr# -> Int# -> ST s [Char] unpackNBytesST# addr# l# = unpackNBytesAccST# addr# l# [] diff --git a/ghc/lib/std/PrelPosixTypes.hsc b/ghc/lib/std/PrelPosixTypes.hsc new file mode 100644 index 0000000..4f3a620 --- /dev/null +++ b/ghc/lib/std/PrelPosixTypes.hsc @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- $Id: PrelPosixTypes.hsc,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +-- +-- (c) 2000 +-- +-- Module PrelPosixTypes + +module PrelPosixTypes where + +import PrelWord +import PrelInt + +#include +#include + +data CDir = CDir + +type CDev = #type dev_t +type CGid = #type gid_t +type CIno = #type ino_t +type CMode = #type mode_t +type CNlink = #type nlink_t +type COff = #type off_t +type CPid = #type pid_t +type CSsize = #type ssize_t +type CUid = #type uid_t +type CCc = #type cc_t +type CSpeed = #type speed_t +type CTcflag = #type tcflag_t +type CTime = #type time_t diff --git a/ghc/lib/std/PrelPtr.lhs b/ghc/lib/std/PrelPtr.lhs new file mode 100644 index 0000000..00a277a --- /dev/null +++ b/ghc/lib/std/PrelPtr.lhs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- $Id: PrelPtr.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +-- +-- (c) 2000 +-- +-- Module PrelPtr + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} +module PrelPtr{-everything-} where + +import PrelBase + +------------------------------------------------------------------------ +-- Data pointers. + +data Ptr a = Ptr Addr# deriving (Eq, Ord) + +nullPtr :: Ptr a +nullPtr = Ptr (int2Addr# 0#) + +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)) + +alignPtr :: Ptr a -> Int -> Ptr a +alignPtr addr@(Ptr a) (I# i) + = case addr2Int# a of { ai -> + case remInt# ai i of { + 0# -> addr; + n -> Ptr (int2Addr# (ai +# (i -# n))) }} + +minusPtr :: Ptr a -> Ptr b -> Int +minusPtr (Ptr a1) (Ptr a2) = I# (addr2Int# a1 -# addr2Int# a2) + +instance CCallable (Ptr a) +instance CReturnable (Ptr a) + +------------------------------------------------------------------------ +-- Function pointers for the default calling convention. + +newtype FunPtr a = FunPtr (Ptr a) deriving (Eq, Ord) + +nullFunPtr :: FunPtr a +nullFunPtr = FunPtr nullPtr + +castFunPtr :: FunPtr a -> FunPtr b +castFunPtr (FunPtr a) = FunPtr (castPtr a) + +castFunPtrToPtr :: FunPtr a -> Ptr b +castFunPtrToPtr (FunPtr a) = castPtr a + +castPtrToFunPtr :: Ptr a -> FunPtr b +castPtrToFunPtr a = FunPtr (castPtr a) + +instance CCallable (FunPtr a) +instance CReturnable (FunPtr a) +\end{code} diff --git a/ghc/lib/std/PrelStorable.lhs b/ghc/lib/std/PrelStorable.lhs new file mode 100644 index 0000000..343b36c --- /dev/null +++ b/ghc/lib/std/PrelStorable.lhs @@ -0,0 +1,302 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelStorable.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +% +% (c) The FFI task force, 2000 +% + +A class for primitive marshaling + +\begin{code} +#include "MachDeps.h" + +module PrelStorable + ( Storable( + sizeOf, -- :: a -> Int + alignment, -- :: a -> Int + peekElemOff, -- :: Ptr a -> Int -> IO a + pokeElemOff, -- :: Ptr a -> Int -> a -> IO () + peekByteOff, -- :: Ptr b -> Int -> IO a + pokeByteOff, -- :: Ptr b -> Int -> a -> IO () + peek, -- :: Ptr a -> IO a + poke) -- :: Ptr a -> a -> IO () + ) where +\end{code} + +\begin{code} +import Char ( chr, ord ) +import Monad ( liftM ) + +#ifdef __GLASGOW_HASKELL__ +import PrelStable ( StablePtr ) +import PrelInt +import PrelWord +import PrelCTypes +import PrelCTypesISO +import PrelStable +import PrelPtr +import PrelFloat +import PrelIOBase +import PrelBase +#endif +\end{code} + +Primitive marshaling + +Minimal complete definition: sizeOf, alignment, and one definition +in each of the peek/poke families. + +\begin{code} +class Storable a where + + -- sizeOf/alignment *never* use their first argument + sizeOf :: a -> Int + alignment :: a -> Int + + -- replacement for read-/write???OffAddr + peekElemOff :: Ptr a -> Int -> IO a + pokeElemOff :: Ptr a -> Int -> a -> IO () + + -- the same with *byte* offsets + peekByteOff :: Ptr b -> Int -> IO a + pokeByteOff :: Ptr b -> Int -> a -> IO () + + -- ... and with no offsets at all + peek :: Ptr a -> IO a + poke :: Ptr a -> a -> IO () + + -- circular default instances + peekElemOff = peekElemOff_ undefined + where peekElemOff_ :: a -> Ptr a -> Int -> IO a + peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef) + pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val + + peekByteOff ptr off = peek (ptr `plusPtr` off) + pokeByteOff ptr off = poke (ptr `plusPtr` off) + + peek ptr = peekElemOff ptr 0 + poke ptr = pokeElemOff ptr 0 +\end{code} + +System-dependent, but rather obvious instances + +\begin{code} +instance Storable Char where + sizeOf _ = sizeOf (undefined::Word32) + alignment _ = alignment (undefined::Word32) + peekElemOff p i = liftM (chr . fromIntegral) $ peekElemOff (castPtr p::Ptr Word32) i + pokeElemOff p i x = pokeElemOff (castPtr p::Ptr Word32) i (fromIntegral (ord x)) + +instance Storable Bool where + sizeOf _ = sizeOf (undefined::CInt) + alignment _ = alignment (undefined::CInt) + peekElemOff p i = liftM (/= (0::CInt)) $ peekElemOff (castPtr p) i + pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::CInt) + +instance Storable (FunPtr a) where + sizeOf (FunPtr x) = sizeOf x + alignment (FunPtr x) = alignment x + peekElemOff p i = liftM FunPtr $ peekElemOff (castPtr p) i + pokeElemOff p i (FunPtr x) = pokeElemOff (castPtr p) i x + +#define STORABLE(T,size,align,read,write) \ +instance Storable (T) where { \ + sizeOf _ = size; \ + alignment _ = align; \ + peekElemOff a i = read a i; \ + pokeElemOff a i x = write a i x } + +STORABLE(Int,SIZEOF_INT,ALIGNMENT_INT, + readIntOffPtr,writeIntOffPtr) + +STORABLE((Ptr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P, + readPtrOffPtr,writePtrOffPtr) + +STORABLE((StablePtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P, + readStablePtrOffPtr,writeStablePtrOffPtr) + +STORABLE(Float,SIZEOF_FLOAT,ALIGNMENT_FLOAT, + readFloatOffPtr,writeFloatOffPtr) + +STORABLE(Double,SIZEOF_DOUBLE,ALIGNMENT_DOUBLE, + readDoubleOffPtr,writeDoubleOffPtr) + +STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8, + readWord8OffPtr,writeWord8OffPtr) + +STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16, + readWord16OffPtr,writeWord16OffPtr) + +STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32, + readWord32OffPtr,writeWord32OffPtr) + +STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64, + readWord64OffPtr,writeWord64OffPtr) + +STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8, + readInt8OffPtr,writeInt8OffPtr) + +STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16, + readInt16OffPtr,writeInt16OffPtr) + +STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32, + readInt32OffPtr,writeInt32OffPtr) + +STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64, + readInt64OffPtr,writeInt64OffPtr) + +#define NSTORABLE(T) \ +instance Storable T where { \ + sizeOf (T x) = sizeOf x ; \ + alignment (T x) = alignment x ; \ + peekElemOff a i = liftM T (peekElemOff (castPtr a) i) ; \ + pokeElemOff a i (T x) = pokeElemOff (castPtr a) i x } + +NSTORABLE(CChar) +NSTORABLE(CSChar) +NSTORABLE(CUChar) +NSTORABLE(CShort) +NSTORABLE(CUShort) +NSTORABLE(CInt) +NSTORABLE(CUInt) +NSTORABLE(CLong) +NSTORABLE(CULong) +NSTORABLE(CLLong) +NSTORABLE(CULLong) +NSTORABLE(CPtrdiff) +NSTORABLE(CSize) +NSTORABLE(CWchar) +NSTORABLE(CSigAtomic) +NSTORABLE(CClock) +NSTORABLE(CTime) +\end{code} + +Helper functions + +\begin{code} +#ifdef __GLASGOW_HASKELL__ + +readIntOffPtr :: Ptr Int -> Int -> IO Int +readPtrOffPtr :: Ptr (Ptr a) -> Int -> IO (Ptr a) +readFloatOffPtr :: Ptr Float -> Int -> IO Float +readDoubleOffPtr :: Ptr Double -> Int -> IO Double +readStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> IO (StablePtr a) +readInt8OffPtr :: Ptr Int8 -> Int -> IO Int8 +readInt16OffPtr :: Ptr Int16 -> Int -> IO Int16 +readInt32OffPtr :: Ptr Int32 -> Int -> IO Int32 +readInt64OffPtr :: Ptr Int64 -> Int -> IO Int64 +readWord8OffPtr :: Ptr Word8 -> Int -> IO Word8 +readWord16OffPtr :: Ptr Word16 -> Int -> IO Word16 +readWord32OffPtr :: Ptr Word32 -> Int -> IO Word32 +readWord64OffPtr :: Ptr Word64 -> Int -> IO Word64 + +readIntOffPtr (Ptr a) (I# i) + = IO $ \s -> case readIntOffAddr# a i s of { (# s,x #) -> (# s, I# x #) } +readPtrOffPtr (Ptr a) (I# i) + = IO $ \s -> case readAddrOffAddr# a i s of { (# s,x #) -> (# s, Ptr x #) } +readFloatOffPtr (Ptr a) (I# i) + = IO $ \s -> case readFloatOffAddr# a i s of { (# s,x #) -> (# s, F# x #) } +readDoubleOffPtr (Ptr a) (I# i) + = IO $ \s -> case readDoubleOffAddr# a i s of { (# s,x #) -> (# s, D# x #) } +readStablePtrOffPtr (Ptr a) (I# i) + = IO $ \s -> case readStablePtrOffAddr# a i s of { (# s,x #) -> (# s, StablePtr x #) } + +readInt8OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt8OffAddr# a i s of (# s, w #) -> (# s, I8# w #) + +readInt16OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt16OffAddr# a i s of (# s, w #) -> (# s, I16# w #) + +readInt32OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt32OffAddr# a i s of (# s, w #) -> (# s, I32# w #) + +#if WORD_SIZE_IN_BYTES == 8 +readInt64OffPtr (Ptr a) (I# i) + = IO $ \s -> case readIntOffAddr# a i s of (# s, w #) -> (# s, I64# w #) +#else +readInt64OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt64OffAddr# a i s of (# s, w #) -> (# s, I64# w #) +#endif + + +writeIntOffPtr :: Ptr Int -> Int -> Int -> IO () +writePtrOffPtr :: Ptr (Ptr a) -> Int -> Ptr a -> IO () +writeFloatOffPtr :: Ptr Float -> Int -> Float -> IO () +writeDoubleOffPtr :: Ptr Double -> Int -> Double -> IO () +writeStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> StablePtr a -> IO () +writeInt8OffPtr :: Ptr Int8 -> Int -> Int8 -> IO () +writeInt16OffPtr :: Ptr Int16 -> Int -> Int16 -> IO () +writeInt32OffPtr :: Ptr Int32 -> Int -> Int32 -> IO () +writeInt64OffPtr :: Ptr Int64 -> Int -> Int64 -> IO () +writeWord8OffPtr :: Ptr Word8 -> Int -> Word8 -> IO () +writeWord16OffPtr :: Ptr Word16 -> Int -> Word16 -> IO () +writeWord32OffPtr :: Ptr Word32 -> Int -> Word32 -> IO () +writeWord64OffPtr :: Ptr Word64 -> Int -> Word64 -> IO () + +writeIntOffPtr (Ptr a#) (I# i#) (I# e#) = IO $ \ s# -> + case (writeIntOffAddr# a# i# e# s#) of s2# -> (# s2#, () #) + +writePtrOffPtr (Ptr a#) (I# i#) (Ptr e#) = IO $ \ s# -> + case (writeAddrOffAddr# a# i# e# s#) of s2# -> (# s2#, () #) + +writeFloatOffPtr (Ptr a#) (I# i#) (F# e#) = IO $ \ s# -> + case (writeFloatOffAddr# a# i# e# s#) of s2# -> (# s2#, () #) + +writeDoubleOffPtr (Ptr a#) (I# i#) (D# e#) = IO $ \ s# -> + case (writeDoubleOffAddr# a# i# e# s#) of s2# -> (# s2#, () #) + +writeStablePtrOffPtr (Ptr a#) (I# i#) (StablePtr e#) = IO $ \ s# -> + case (writeStablePtrOffAddr# a# i# e# s#) of s2# -> (# s2# , () #) + +writeInt8OffPtr (Ptr a#) (I# i#) (I8# w#) = IO $ \ s# -> + case (writeInt8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) + +writeInt16OffPtr (Ptr a#) (I# i#) (I16# w#) = IO $ \ s# -> + case (writeInt16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) + +writeInt32OffPtr (Ptr a#) (I# i#) (I32# w#) = IO $ \ s# -> + case (writeInt32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) + +#if WORD_SIZE_IN_BYTES == 8 +writeInt64OffPtr (Ptr a#) (I# i#) (I64# w#) = IO $ \ s# -> + case (writeIntOffAddr# a# i# w# s#) of s2# -> (# s2#, () #) +#else +writeInt64OffPtr (Ptr a#) (I# i#) (I64# w#) = IO $ \ s# -> + case (writeInt64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) +#endif + +readWord8OffPtr (Ptr a) (I# i) + = IO $ \s -> case readWord8OffAddr# a i s of (# s, w #) -> (# s, W8# w #) + +readWord16OffPtr (Ptr a) (I# i) + = IO $ \s -> case readWord16OffAddr# a i s of (# s, w #) -> (# s, W16# w #) + +readWord32OffPtr (Ptr a) (I# i) + = IO $ \s -> case readWord32OffAddr# a i s of (# s, w #) -> (# s, W32# w #) + +#if WORD_SIZE_IN_BYTES == 8 +readWord64OffPtr (Ptr a) (I# i) + = IO $ \s -> case readWordOffAddr# a i s of (# s, w #) -> (# s, W64# w #) +#else +readWord64OffPtr (Ptr a) (I# i) + = IO $ \s -> case readWord64OffAddr# a i s of (# s, w #) -> (# s, W64# w #) +#endif + +writeWord8OffPtr (Ptr a#) (I# i#) (W8# w#) = IO $ \ s# -> + case (writeWord8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) + +writeWord16OffPtr (Ptr a#) (I# i#) (W16# w#) = IO $ \ s# -> + case (writeWord16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) + +writeWord32OffPtr (Ptr a#) (I# i#) (W32# w#) = IO $ \ s# -> + case (writeWord32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) + +#if WORD_SIZE_IN_BYTES == 8 +writeWord64OffPtr (Ptr a#) (I# i#) (W64# w#) = IO $ \ s# -> + case (writeWordOffAddr# a# i# w# s#) of s2# -> (# s2#, () #) +#else +writeWord64OffPtr (Ptr a#) (I# i#) (W64# w#) = IO $ \ s# -> + case (writeWord64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) +#endif + +#endif /* __GLASGOW_HASKELL__ */ +\end{code} diff --git a/ghc/lib/std/PrelWeak.lhs b/ghc/lib/std/PrelWeak.lhs index 5c9f22c..76f4c8c 100644 --- a/ghc/lib/std/PrelWeak.lhs +++ b/ghc/lib/std/PrelWeak.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelWeak.lhs,v 1.14 2001/01/03 14:47:18 simonmar Exp $ +% $Id: PrelWeak.lhs,v 1.15 2001/01/11 17:25:57 simonmar Exp $ % % (c) The University of Glasgow, 1998-2000 % @@ -14,8 +14,7 @@ module PrelWeak where import PrelGHC import PrelBase import PrelMaybe --- NOTE: To break a cycle, ForeignObj is not in PrelForeign, but PrelIOBase! -import PrelIOBase ( IO(..), unIO, ForeignObj(..) ) +import PrelIOBase ( IO(..), unIO ) #ifndef __PARALLEL_HASKELL__ @@ -39,10 +38,6 @@ addFinalizer key finalizer = do mkWeakPtr key (Just finalizer) -- throw it away return () -addForeignFinalizer :: ForeignObj -> IO () -> IO () -addForeignFinalizer (ForeignObj fo) finalizer - = IO $ \s -> case mkWeak# fo () finalizer s of { (# s1, w #) -> (# s1, () #) } - {- Instance Eq (Weak v) where (Weak w1) == (Weak w2) = w1 `sameWeak#` w2 diff --git a/ghc/lib/std/PrelWord.lhs b/ghc/lib/std/PrelWord.lhs index f51d9f9..a09a0d1 100644 --- a/ghc/lib/std/PrelWord.lhs +++ b/ghc/lib/std/PrelWord.lhs @@ -9,7 +9,7 @@ #include "MachDeps.h" module PrelWord ( - Word8(..), Word16(..), Word32(..), Word64(..), + Word(..), Word8(..), Word16(..), Word32(..), Word64(..), -- SUP: deprecated in the new FFI, subsumed by fromIntegral , intToWord8 -- :: Int -> Word8 @@ -46,36 +46,7 @@ module PrelWord ( , word64ToWord16 -- :: Word64 -> Word16 , word64ToWord32 -- :: Word64 -> Word32 - -- NB! GHC SPECIFIC: - , wordToWord8 -- :: Word -> Word8 - , wordToWord16 -- :: Word -> Word16 - , wordToWord32 -- :: Word -> Word32 - , wordToWord64 -- :: Word -> Word64 - - , word8ToWord -- :: Word8 -> Word - , word16ToWord -- :: Word16 -> Word - , word32ToWord -- :: Word32 -> Word - , word64ToWord -- :: Word64 -> Word - - -- The "official" place to get these from is Addr. - -- SUP: deprecated in the new FFI, subsumed by the Storable class - , indexWord8OffAddr - , indexWord16OffAddr - , indexWord32OffAddr - , indexWord64OffAddr - - , readWord8OffAddr - , readWord16OffAddr - , readWord32OffAddr - , readWord64OffAddr - - , writeWord8OffAddr - , writeWord16OffAddr - , writeWord32OffAddr - , writeWord64OffAddr - -- internal stuff - , wordToInt , wordToWord8#, wordToWord16#, wordToWord32#, wordToWord64# , word64ToInt64#, int64ToWord64# @@ -84,18 +55,25 @@ module PrelWord ( , toEnumError, fromEnumError, succError, predError, divZeroError ) where -import Numeric ( showInt ) - import PrelArr +import PrelBits import PrelRead -import PrelIOBase import PrelEnum -import PrelAddr import PrelReal import PrelNum import PrelBase -- --------------------------------------------------------------------------- +-- The Word Type +-- --------------------------------------------------------------------------- + +-- A Word is an unsigned integral type, with the same number of bits as Int. +data Word = W# Word# deriving (Eq, Ord) + +instance CCallable Word +instance CReturnable Word + +-- --------------------------------------------------------------------------- -- Coercion functions (DEPRECATED) -- --------------------------------------------------------------------------- @@ -133,16 +111,6 @@ word64ToWord8 :: Word64 -> Word8 word64ToWord16 :: Word64 -> Word16 word64ToWord32 :: Word64 -> Word32 -wordToWord8 :: Word -> Word8 -wordToWord16 :: Word -> Word16 -wordToWord32 :: Word -> Word32 -wordToWord64 :: Word -> Word64 - -word8ToWord :: Word8 -> Word -word16ToWord :: Word16 -> Word -word32ToWord :: Word32 -> Word -word64ToWord :: Word64 -> Word - intToWord8 = word32ToWord8 . intToWord32 intToWord16 = word32ToWord16 . intToWord32 @@ -163,6 +131,12 @@ intToWord32 (I# x) = W32# (int2Word# x) word32ToInt (W32# x) = I# (word2Int# x) +word2Integer :: Word# -> Integer +word2Integer w | i >=# 0# = S# i + | otherwise = case word2Integer# w of + (# s, d #) -> J# s d + where i = word2Int# w + word32ToInteger (W32# x) = word2Integer x integerToWord32 = fromInteger @@ -339,20 +313,56 @@ instance Read Word8 where readsPrec _ = readDec instance Show Word8 where - showsPrec _ = showInt -\end{code} + showsPrec p w8 = showsPrec p (word8ToInt w8) + +instance Bits Word8 where + (W8# x) .&. (W8# y) = W8# (x `and#` y) + (W8# x) .|. (W8# y) = W8# (x `or#` y) + (W8# x) `xor` (W8# y) = W8# (x `xor#` y) + complement (W8# x) = W8# (x `xor#` int2Word# 0xff#) + shift (W8# x#) i@(I# i#) + | i > 0 = W8# (wordToWord8# (shiftL# x# i#)) + | otherwise = W8# (wordToWord8# (shiftRL# x# (negateInt# i#))) + w@(W8# x) `rotate` (I# i) + | i ==# 0# = w + | i ># 0# = W8# ((wordToWord8# (shiftL# x i')) `or#` + (shiftRL# (x `and#` + (int2Word# (0x100# -# pow2# i2))) + i2)) + | otherwise = rotate w (I# (8# +# i)) + where + i' = word2Int# (int2Word# i `and#` int2Word# 7#) + i2 = 8# -# i' + + bit (I# i#) + | i# >=# 0# && i# <=# 7# = W8# (wordToWord8# (shiftL# (int2Word# 1#) i#)) + | otherwise = 0 -- We'll be overbearing, for now.. + + testBit (W8# x#) (I# i#) + | i# <# 8# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0# + | otherwise = False -- for now, this is really an error. + + bitSize _ = 8 + isSigned _ = False + +pow2# :: Int# -> Int# +pow2# x# = word2Int# (shiftL# (int2Word# 1#) x#) + +pow2_64# :: Int# -> Int64# +pow2_64# x# = word64ToInt64# (shiftL64# (wordToWord64# (int2Word# 1#)) x#) -\subsection[Word16]{The @Word16@ interface} +-- --------------------------------------------------------------------------- +-- Word16 +-- --------------------------------------------------------------------------- -The double byte type @Word16@ is represented in the Haskell -heap by boxing up a machine word, @Word#@. An invariant -for this representation is that only the lower 16 bits are -`active', any bits above are {\em always} zeroed out. -A consequence of this is that operations that could possibly -overflow have to mask out anything above the lower two bytes -before putting together the resulting @Word16@. +-- The double byte type @Word16@ is represented in the Haskell +-- heap by boxing up a machine word, @Word#@. An invariant +-- for this representation is that only the lower 16 bits are +-- `active', any bits above are {\em always} zeroed out. +-- A consequence of this is that operations that could possibly +-- overflow have to mask out anything above the lower two bytes +-- before putting together the resulting @Word16@. -\begin{code} data Word16 = W16# Word# instance CCallable Word16 @@ -465,19 +475,48 @@ instance Read Word16 where readsPrec _ = readDec instance Show Word16 where - showsPrec _ = showInt -\end{code} + showsPrec p w16 = showsPrec p (word16ToInt w16) + +instance Bits Word16 where + (W16# x) .&. (W16# y) = W16# (x `and#` y) + (W16# x) .|. (W16# y) = W16# (x `or#` y) + (W16# x) `xor` (W16# y) = W16# (x `xor#` y) + complement (W16# x) = W16# (x `xor#` int2Word# 0xffff#) + shift (W16# x#) i@(I# i#) + | i > 0 = W16# (wordToWord16# (shiftL# x# i#)) + | otherwise = W16# (shiftRL# x# (negateInt# i#)) + w@(W16# x) `rotate` (I# i) + | i ==# 0# = w + | i ># 0# = W16# ((wordToWord16# (shiftL# x i')) `or#` + (shiftRL# (x `and#` + (int2Word# (0x10000# -# pow2# i2))) + i2)) + | otherwise = rotate w (I# (16# +# i')) + where + i' = word2Int# (int2Word# i `and#` int2Word# 15#) + i2 = 16# -# i' + bit (I# i#) + | i# >=# 0# && i# <=# 15# = W16# (shiftL# (int2Word# 1#) i#) + | otherwise = 0 -- We'll be overbearing, for now.. + + testBit (W16# x#) (I# i#) + | i# <# 16# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0# + | otherwise = False -- for now, this is really an error. + + bitSize _ = 16 + isSigned _ = False -\subsection[Word32]{The @Word32@ interface} +-- --------------------------------------------------------------------------- +-- Word32 +-- --------------------------------------------------------------------------- -The quad byte type @Word32@ is represented in the Haskell -heap by boxing up a machine word, @Word#@. An invariant -for this representation is that any bits above the lower -32 are {\em always} zeroed out. A consequence of this is that -operations that could possibly overflow have to mask -the result before building the resulting @Word16@. +-- The quad byte type @Word32@ is represented in the Haskell +-- heap by boxing up a machine word, @Word#@. An invariant +-- for this representation is that any bits above the lower +-- 32 are {\em always} zeroed out. A consequence of this is that +-- operations that could possibly overflow have to mask +-- the result before building the resulting @Word16@. -\begin{code} data Word32 = W32# Word# instance CCallable Word32 @@ -648,14 +687,44 @@ instance Read Word32 where readsPrec _ = readDec instance Show Word32 where - showsPrec _ = showInt + showsPrec p w = showsPrec p (word32ToInteger w) + +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 + shift (W32# x) i@(I# i#) + | i > 0 = W32# (wordToWord32# (shiftL# x i#)) + | otherwise = W32# (shiftRL# x (negateInt# i#)) + w@(W32# x) `rotate` (I# i) + | i ==# 0# = w + | i ># 0# = W32# ((wordToWord32# (shiftL# x i')) `or#` + (shiftRL# (x `and#` + (int2Word# (word2Int# maxBound# -# pow2# i2 +# 1#))) + i2)) + | otherwise = rotate w (I# (32# +# i)) + where + i' = word2Int# (int2Word# i `and#` int2Word# 31#) + i2 = 32# -# i' + (W32# maxBound#) = maxBound + + bit (I# i#) + | i# >=# 0# && i# <=# 31# = W32# (shiftL# (int2Word# 1#) i#) + | otherwise = 0 -- We'll be overbearing, for now.. + + testBit (W32# x#) (I# i#) + | i# <# 32# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0# + | otherwise = False -- for now, this is really an error. + bitSize _ = 32 + isSigned _ = False -- ----------------------------------------------------------------------------- -- Word64 -- ----------------------------------------------------------------------------- #if WORD_SIZE_IN_BYTES == 8 ---data Word64 = W64# Word# +data Word64 = W64# Word# word32ToWord64 (W32 w#) = W64# w# @@ -735,7 +804,7 @@ instance Integral Word64 where #else /* WORD_SIZE_IN_BYTES < 8 */ ---defined in PrelCCall: data Word64 = W64 Word64# deriving (Eq, Ord, Bounded) +data Word64 = W64# Word64# -- for completeness sake word32ToWord64 (W32# w#) = W64# (wordToWord64# w#) @@ -814,76 +883,46 @@ compareWord64# i# j# -- Word64# primop wrappers: ltWord64# :: Word64# -> Word64# -> Bool -ltWord64# x# y# = stg_ltWord64 x# y# /= 0 +ltWord64# x# y# = stg_ltWord64 x# y# /=# 0# leWord64# :: Word64# -> Word64# -> Bool -leWord64# x# y# = stg_leWord64 x# y# /= 0 +leWord64# x# y# = stg_leWord64 x# y# /=# 0# eqWord64# :: Word64# -> Word64# -> Bool -eqWord64# x# y# = stg_eqWord64 x# y# /= 0 +eqWord64# x# y# = stg_eqWord64 x# y# /=# 0# neWord64# :: Word64# -> Word64# -> Bool -neWord64# x# y# = stg_neWord64 x# y# /= 0 +neWord64# x# y# = stg_neWord64 x# y# /=# 0# geWord64# :: Word64# -> Word64# -> Bool -geWord64# x# y# = stg_geWord64 x# y# /= 0 +geWord64# x# y# = stg_geWord64 x# y# /=# 0# gtWord64# :: Word64# -> Word64# -> Bool -gtWord64# x# y# = stg_gtWord64 x# y# /= 0 - -plusInt64# :: Int64# -> Int64# -> Int64# -plusInt64# a# b# = case stg_plusInt64 a# b# of { I64# i# -> i# } - -minusInt64# :: Int64# -> Int64# -> Int64# -minusInt64# a# b# = case stg_minusInt64 a# b# of { I64# i# -> i# } - -timesInt64# :: Int64# -> Int64# -> Int64# -timesInt64# a# b# = case stg_timesInt64 a# b# of { I64# i# -> i# } - -quotWord64# :: Word64# -> Word64# -> Word64# -quotWord64# a# b# = case stg_quotWord64 a# b# of { W64# w# -> w# } - -remWord64# :: Word64# -> Word64# -> Word64# -remWord64# a# b# = case stg_remWord64 a# b# of { W64# w# -> w# } - -negateInt64# :: Int64# -> Int64# -negateInt64# a# = case stg_negateInt64 a# of { I64# i# -> i# } - -word64ToWord# :: Word64# -> Word# -word64ToWord# w64# = case stg_word64ToWord w64# of { W# w# -> w# } - -wordToWord64# :: Word# -> Word64# -wordToWord64# w# = case stg_wordToWord64 w# of { W64# w64# -> w64# } - -word64ToInt64# :: Word64# -> Int64# -word64ToInt64# w64# = case stg_word64ToInt64 w64# of { I64# i# -> i# } - -int64ToWord64# :: Int64# -> Word64# -int64ToWord64# i64# = case stg_int64ToWord64 i64# of { W64# w# -> w# } - -intToInt64# :: Int# -> Int64# -intToInt64# i# = case stg_intToInt64 i# of { I64# i64# -> i64# } - -foreign import "stg_intToInt64" unsafe stg_intToInt64 :: Int# -> Int64 -foreign import "stg_int64ToWord64" unsafe stg_int64ToWord64 :: Int64# -> Word64 -foreign import "stg_word64ToInt64" unsafe stg_word64ToInt64 :: Word64# -> Int64 -foreign import "stg_wordToWord64" unsafe stg_wordToWord64 :: Word# -> Word64 -foreign import "stg_word64ToWord" unsafe stg_word64ToWord :: Word64# -> Word -foreign import "stg_negateInt64" unsafe stg_negateInt64 :: Int64# -> Int64 -foreign import "stg_remWord64" unsafe stg_remWord64 :: Word64# -> Word64# -> Word64 -foreign import "stg_quotWord64" unsafe stg_quotWord64 :: Word64# -> Word64# -> Word64 -foreign import "stg_timesInt64" unsafe stg_timesInt64 :: Int64# -> Int64# -> Int64 -foreign import "stg_minusInt64" unsafe stg_minusInt64 :: Int64# -> Int64# -> Int64 -foreign import "stg_plusInt64" unsafe stg_plusInt64 :: Int64# -> Int64# -> Int64 -foreign import "stg_gtWord64" unsafe stg_gtWord64 :: Word64# -> Word64# -> Int -foreign import "stg_geWord64" unsafe stg_geWord64 :: Word64# -> Word64# -> Int -foreign import "stg_neWord64" unsafe stg_neWord64 :: Word64# -> Word64# -> Int -foreign import "stg_eqWord64" unsafe stg_eqWord64 :: Word64# -> Word64# -> Int -foreign import "stg_leWord64" unsafe stg_leWord64 :: Word64# -> Word64# -> Int -foreign import "stg_ltWord64" unsafe stg_ltWord64 :: Word64# -> Word64# -> Int +gtWord64# x# y# = stg_gtWord64 x# y# /=# 0# + +foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64# +foreign import "stg_int64ToWord64" unsafe int64ToWord64# :: Int64# -> Word64# +foreign import "stg_word64ToInt64" unsafe word64ToInt64# :: Word64# -> Int64# +foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64# +foreign import "stg_word64ToWord" unsafe word64ToWord# :: Word64# -> Word# +foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64# +foreign import "stg_remWord64" unsafe remWord64# :: Word64# -> Word64# -> Word64# +foreign import "stg_quotWord64" unsafe quotWord64# :: Word64# -> Word64# -> Word64# +foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64# +foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64# +foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64# +foreign import "stg_gtWord64" unsafe stg_gtWord64 :: Word64# -> Word64# -> Int# +foreign import "stg_geWord64" unsafe stg_geWord64 :: Word64# -> Word64# -> Int# +foreign import "stg_neWord64" unsafe stg_neWord64 :: Word64# -> Word64# -> Int# +foreign import "stg_eqWord64" unsafe stg_eqWord64 :: Word64# -> Word64# -> Int# +foreign import "stg_leWord64" unsafe stg_leWord64 :: Word64# -> Word64# -> Int# +foreign import "stg_ltWord64" unsafe stg_ltWord64 :: Word64# -> Word64# -> Int# #endif +instance CCallable Word64 +instance CReturnable Word64 + instance Enum Word64 where succ w | w == maxBound = succError "Word64" @@ -934,94 +973,83 @@ instance Bounded Word64 where instance Real Word64 where toRational x = toInteger x % 1 --- ----------------------------------------------------------------------------- --- Reading/writing words to/from memory --- ----------------------------------------------------------------------------- - -indexWord8OffAddr :: Addr -> Int -> Word8 -indexWord8OffAddr (A# a#) (I# i#) = W8# (indexWord8OffAddr# a# i#) - -indexWord16OffAddr :: Addr -> Int -> Word16 -indexWord16OffAddr (A# a#) (I# i#) = W16# (indexWord16OffAddr# a# i#) - -indexWord32OffAddr :: Addr -> Int -> Word32 -indexWord32OffAddr (A# a#) (I# i#) = W32# (indexWord32OffAddr# a# i#) - -indexWord64OffAddr :: Addr -> Int -> Word64 -#if WORD_SIZE_IN_BYTES == 8 -indexWord64OffAddr (A# a#) (I# i#) = W64# (indexWordOffAddr# a# i#) -#else -indexWord64OffAddr (A# a#) (I# i#) = W64# (indexWord64OffAddr# a# i#) -#endif - - -readWord8OffAddr :: Addr -> Int -> IO Word8 -readWord8OffAddr (A# a) (I# i) - = IO $ \s -> case readWord8OffAddr# a i s of (# s, w #) -> (# s, W8# w #) - -readWord16OffAddr :: Addr -> Int -> IO Word16 -readWord16OffAddr (A# a) (I# i) - = IO $ \s -> case readWord16OffAddr# a i s of (# s, w #) -> (# s, W16# w #) - -readWord32OffAddr :: Addr -> Int -> IO Word32 -readWord32OffAddr (A# a) (I# i) - = IO $ \s -> case readWord32OffAddr# a i s of (# s, w #) -> (# s, W32# w #) - -readWord64OffAddr :: Addr -> Int -> IO Word64 -#if WORD_SIZE_IN_BYTES == 8 -readWord64OffAddr (A# a) (I# i) - = IO $ \s -> case readWordOffAddr# a i s of (# s, w #) -> (# s, W64# w #) -#else -readWord64OffAddr (A# a) (I# i) - = IO $ \s -> case readWord64OffAddr# a i s of (# s, w #) -> (# s, W64# w #) -#endif - - -writeWord8OffAddr :: Addr -> Int -> Word8 -> IO () -writeWord8OffAddr (A# a#) (I# i#) (W8# w#) = IO $ \ s# -> - case (writeWord8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) - -writeWord16OffAddr :: Addr -> Int -> Word16 -> IO () -writeWord16OffAddr (A# a#) (I# i#) (W16# w#) = IO $ \ s# -> - case (writeWord16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) - -writeWord32OffAddr :: Addr -> Int -> Word32 -> IO () -writeWord32OffAddr (A# a#) (I# i#) (W32# w#) = IO $ \ s# -> - case (writeWord32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) - -writeWord64OffAddr :: Addr -> Int -> Word64 -> IO () #if WORD_SIZE_IN_BYTES == 8 -writeWord64OffAddr (A# a#) (I# i#) (W64# w#) = IO $ \ s# -> - case (writeWordOffAddr# a# i# w# s#) of s2# -> (# s2#, () #) -#else -writeWord64OffAddr (A# a#) (I# i#) (W64# w#) = IO $ \ s# -> - case (writeWord64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #) -#endif -\end{code} - -The Hugs-GHC extension libraries provide functions for going between -Int and the various (un)signed ints. Here we provide the same for -the GHC specific Word type: -\begin{code} -word8ToWord (W8# w#) = W# w# -wordToWord8 (W# w#) = W8# (w# `and#` (case (maxBound::Word8) of W8# x# -> x#)) - -word16ToWord (W16# w#) = W# w# -wordToWord16 (W# w#) = W16# (w# `and#` (case (maxBound::Word16) of W16# x# -> x#)) - -word32ToWord (W32# w#) = W# w# -wordToWord32 (W# w#) = W32# (w# `and#` (case (maxBound::Word32) of W32# x# -> x#)) +instance Bits Word64 where + (W64# x) .&. (W64# y) = W64# (x `and#` y) + (W64# x) .|. (W64# y) = W64# (x `or#` y) + (W64# x) `xor` (W64# y) = W64# (x `xor#` y) + complement (W64# x) = W64# (x `xor#` (case (maxBound::Word64) of W64# x# -> x#)) + shift (W64# x#) i@(I# i#) + | i > 0 = W64# (shiftL# x# i#) + | otherwise = W64# (shiftRL# x# (negateInt# i#)) + + w@(W64# x) `rotate` (I# i) + | i ==# 0# = w + | i ># 0# = W64# (shiftL# x i') `or#` + (shiftRL# (x `and#` + (int2Word# (word2Int# maxBound# -# pow2# i2 +# 1#))) + i2)) + | otherwise = rotate w (I# (64# +# i)) + where + i' = word2Int# (int2Word# i `and#` int2Word# 63#) + i2 = 64# -# i' + (W64# maxBound#) = maxBound + + bit (I# i#) + | i# >=# 0# && i# <=# 63# = W64# (shiftL# (int2Word# 1#) i#) + | otherwise = 0 -- We'll be overbearing, for now.. + + testBit (W64# x#) (I# i#) + | i# <# 64# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0# + | otherwise = False -- for now, this is really an error. + + bitSize _ = 64 + isSigned _ = False -wordToWord64 (W# w#) = W64# (wordToWord64# w#) --- lossy on 32-bit platforms, but provided nontheless. -word64ToWord (W64# w#) = W# (word64ToWord# w#) +#else /* WORD_SIZE_IN_BYTES < 8 */ -word2Integer :: Word# -> Integer -word2Integer w | i >=# 0# = S# i - | otherwise = case word2Integer# w of - (# s, d #) -> J# s d - where i = word2Int# w +instance Bits Word64 where + (W64# x) .&. (W64# y) = W64# (x `and64#` y) + (W64# x) .|. (W64# y) = W64# (x `or64#` y) + (W64# x) `xor` (W64# y) = W64# (x `xor64#` y) + complement (W64# x) = W64# (x `xor64#` (case (maxBound::Word64) of W64# x# -> x#)) + shift (W64# x#) i@(I# i#) + | i > 0 = W64# (shiftL64# x# i#) + | otherwise = W64# (shiftRL64# x# (negateInt# i#)) + + w@(W64# x) `rotate` (I# i) + | i ==# 0# = w + | i ># 0# = W64# ((shiftL64# x i') `or64#` + (shiftRL64# (x `and64#` + (int64ToWord64# ((word64ToInt64# maxBound#) `minusInt64#` + (pow2_64# i2 `plusInt64#` (intToInt64# 1#)))))) + i2) + | otherwise = rotate w (I# (64# +# i)) + where + i' = word2Int# (int2Word# i `and#` int2Word# 63#) + i2 = 64# -# i' + (W64# maxBound#) = maxBound + + bit (I# i#) + | i# >=# 0# && i# <=# 63# = W64# (shiftL64# (wordToWord64# (int2Word# 1#)) i#) + | otherwise = 0 -- We'll be overbearing, for now.. + + testBit (W64# x#) (I# i#) + | i# <# 64# && i# >=# 0# = (word2Int# (word64ToWord# (x# `and64#` (shiftL64# (wordToWord64# (int2Word# 1#)) i#)))) /=# 0# + | otherwise = False -- for now, this is really an error. + + bitSize _ = 64 + isSigned _ = False + +foreign import "stg_not64" unsafe not64# :: Word64# -> Word64# +foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64# +foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64# +foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64# +foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64# +foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64# + +#endif /* WORD_SIZE_IN_BYTES < 8 */ \end{code} Misc utils. diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index 0cfec05..8ae428c 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: System.lhs,v 1.27 2001/01/11 07:04:16 qrczak Exp $ +% $Id: System.lhs,v 1.28 2001/01/11 17:25:57 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -20,24 +20,17 @@ module System ) where \end{code} - -#ifndef __HUGS__ \begin{code} +import Monad import Prelude -import PrelAddr +import PrelCString +import PrelCTypes +import PrelMarshalArray +import PrelPtr +import PrelStorable import PrelIOBase ( IOException(..), ioException, - IOErrorType(..), constructErrorAndFailWithInfo, stToIO ) -import PrelPack ( unpackCString, unpackCStringST, packString ) + IOErrorType(..), constructErrorAndFailWithInfo ) import PrelByteArr ( ByteArray ) - -type PrimByteArray = ByteArray Int - -primUnpackCString :: Addr -> IO String -primUnpackCString s = stToIO ( unpackCStringST s ) - -primPackString :: String -> PrimByteArray -primPackString s = packString s - \end{code} %********************************************************* @@ -63,19 +56,19 @@ Computation $getArgs$ returns a list of the program's command line arguments (not including the program name). \begin{code} -getArgs :: IO [String] -getArgs = return (unpackArgv primArgv primArgc) +getArgs :: IO [String] +getArgs = unpackArgv primArgv primArgc -foreign import ccall "libHS_cbits.so" "get_prog_argv" unsafe primArgv :: Addr -foreign import ccall "libHS_cbits.so" "get_prog_argc" unsafe primArgc :: Int +foreign import ccall "get_prog_argv" unsafe primArgv :: Ptr (Ptr CChar) +foreign import ccall "get_prog_argc" unsafe primArgc :: Int \end{code} Computation $getProgName$ returns the name of the program as it was invoked. \begin{code} -getProgName :: IO String -getProgName = return (unpackProgName primArgv) +getProgName :: IO String +getProgName = unpackProgName primArgv \end{code} Computation $getEnv var$ returns the value @@ -88,15 +81,16 @@ The environment variable does not exist. \end{itemize} \begin{code} -getEnv :: String -> IO String -getEnv name = do - litstring <- primGetEnv (primPackString name) - if litstring /= nullAddr - then primUnpackCString litstring +getEnv :: String -> IO String +getEnv name = + withUnsafeCString name $ \s -> do + litstring <- _getenv s + if litstring /= nullPtr + then peekCString litstring else ioException (IOError Nothing NoSuchThing "getEnv" "no environment variable" (Just name)) -foreign import ccall "libHS_cbits.so" "getenv" unsafe primGetEnv :: PrimByteArray -> IO Addr +foreign import ccall "getenv" unsafe _getenv :: UnsafeCString -> IO (Ptr CChar) \end{code} Computation $system cmd$ returns the exit code @@ -115,14 +109,15 @@ The implementation does not support system calls. \begin{code} system :: String -> IO ExitCode system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing) -system cmd = do - status <- primSystem (primPackString cmd) +system cmd = + withUnsafeCString cmd $ \s -> do + status <- primSystem s case status of 0 -> return ExitSuccess -1 -> constructErrorAndFailWithInfo "system" cmd n -> return (ExitFailure n) -foreign import ccall "libHS_cbits.so" "systemCmd" unsafe primSystem :: PrimByteArray -> IO Int +foreign import ccall "systemCmd" unsafe primSystem :: UnsafeCString -> IO Int \end{code} @exitWith code@ terminates the program, returning {\em code} to the program's caller. @@ -156,23 +151,13 @@ exitFailure = exitWith (ExitFailure 1) %********************************************************* \begin{code} -type CHAR_STAR_STAR = Addr -- this is all a HACK -type CHAR_STAR = Addr - -unpackArgv :: CHAR_STAR_STAR -> Int -> [String] -- argv[1 .. argc-1] -unpackArgv argv argc = unpack 1 - where - unpack :: Int -> [String] - unpack n - | n >= argc = [] - | otherwise = - case (indexAddrOffAddr argv n) of - item -> unpackCString item : unpack (n + 1) +unpackArgv :: Ptr (Ptr CChar) -> Int -> IO [String] -- argv[1 .. argc-1] +unpackArgv argv argc = peekArray argc argv >>= mapM peekCString -unpackProgName :: CHAR_STAR_STAR -> String -- argv[0] -unpackProgName argv - = case (indexAddrOffAddr argv 0) of { prog -> - de_slash [] (unpackCString prog) } +unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] +unpackProgName argv = do + s <- peekElemOff argv 0 >>= peekCString + return (de_slash "" s) where -- re-start accumulating at every '/' de_slash :: String -> String -> String @@ -180,90 +165,3 @@ unpackProgName argv de_slash _acc ('/':xs) = de_slash [] xs de_slash acc (x:xs) = de_slash (x:acc) xs \end{code} - -#else - -\begin{code} ------------------------------------------------------------------------------ --- Standard Library: System operations --- --- Warning: the implementation of these functions in Hugs 98 is very weak. --- The functions themselves are best suited to uses in compiled programs, --- and not to use in an interpreter-based environment like Hugs. --- --- Suitable for use with Hugs 98 ------------------------------------------------------------------------------ -import PrelPrim ( primGetRawArgs - , primGetEnv - , prelCleanupAfterRunAction - , copy_String_to_cstring - , readIORef - , nh_stderr - , nh_stdout - , nh_stdin - , nh_exitwith - , nh_flush - , nh_close - , nh_system - , nh_free - , nh_getPID - ) - - -data ExitCode = ExitSuccess | ExitFailure Int - deriving (Eq, Ord, Read, Show) - -getArgs :: IO [String] -getArgs = primGetRawArgs >>= \rawargs -> - return (tail rawargs) - -getProgName :: IO String -getProgName = primGetRawArgs >>= \rawargs -> - return (head rawargs) - -getEnv :: String -> IO String -getEnv = primGetEnv - -exitFailure :: IO a -exitFailure = exitWith (ExitFailure 1) - -toExitCode :: Int -> ExitCode -toExitCode 0 = ExitSuccess -toExitCode n = ExitFailure n - -fromExitCode :: ExitCode -> Int -fromExitCode ExitSuccess = 0 -fromExitCode (ExitFailure n) = n - --- see comment in Prelude.hs near primRunIO_hugs_toplevel -exitWith :: ExitCode -> IO a -exitWith c - = do cleanup_action <- readIORef prelCleanupAfterRunAction - case cleanup_action of - Just xx -> xx - Nothing -> return () - nh_stderr >>= nh_flush - nh_stdout >>= nh_flush - nh_stdin >>= nh_close - nh_exitwith (fromExitCode c) - (ioException . IOError) "System.exitWith: should not return" - -system :: String -> IO ExitCode -system cmd - | null cmd - = (ioException.IOError) "System.system: null command" - | otherwise - = do str <- copy_String_to_cstring cmd - status <- nh_system str - nh_free str - case status of - 0 -> return ExitSuccess - n -> return (ExitFailure n) - -getPID :: IO Int -getPID - = nh_getPID - ------------------------------------------------------------------------------ -\end{code} -#endif diff --git a/ghc/lib/std/Time.lhs b/ghc/lib/std/Time.lhs index 302fca2..1cb55f1 100644 --- a/ghc/lib/std/Time.lhs +++ b/ghc/lib/std/Time.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: Time.lhs,v 1.24 2000/12/12 12:19:58 simonmar Exp $ +% $Id: Time.lhs,v 1.25 2001/01/11 17:25:57 simonmar Exp $ % % (c) The University of Glasgow, 1995-2000 % @@ -110,7 +110,7 @@ import PrelPack ( unpackCString, unpackCStringBA, ) import PrelByteArr ( MutableByteArray(..), wORD_SCALE ) import PrelHandle ( Bytes ) -import PrelAddr ( Addr ) +import PrelPtr #endif @@ -719,14 +719,14 @@ foreign import "libHS_cbits" "prim_SETZONE" unsafe prim_SETZONE :: MBytes -> MBy #ifdef __HUGS__ foreign import "libHS_cbits" "prim_toLocalTime" unsafe prim_toLocalTime :: Int64 -> MBytes -> IO Int foreign import "libHS_cbits" "prim_toUTCTime" unsafe prim_toUTCTime :: Int64 -> MBytes -> IO Int -foreign import "libHS_cbits" "prim_ZONE" unsafe prim_ZONE :: Bytes -> IO Addr +foreign import "libHS_cbits" "prim_ZONE" unsafe prim_ZONE :: Bytes -> IO (Ptr ()) foreign import "libHS_cbits" "prim_GMTOFF" unsafe prim_GMTOFF :: Bytes -> IO Int #else foreign import "libHS_cbits" "toLocalTime" unsafe prim_toLocalTime :: Int -> Bytes -> MBytes -> IO Int foreign import "libHS_cbits" "toUTCTime" unsafe prim_toUTCTime :: Int -> Bytes -> MBytes -> IO Int #endif -foreign import "libHS_cbits" "get_ZONE" unsafe get_ZONE :: MBytes -> IO Addr +foreign import "libHS_cbits" "get_ZONE" unsafe get_ZONE :: MBytes -> IO (Ptr ()) foreign import "libHS_cbits" "GMTOFF" unsafe get_GMTOFF :: MBytes -> IO Int diff --git a/ghc/lib/std/cbits/CTypes.h b/ghc/lib/std/cbits/CTypes.h new file mode 100644 index 0000000..00f9ba8 --- /dev/null +++ b/ghc/lib/std/cbits/CTypes.h @@ -0,0 +1,352 @@ +/* ----------------------------------------------------------------------------- + * $Id: CTypes.h,v 1.1 2001/01/11 17:25:58 simonmar Exp $ + * + * Dirty CPP hackery for CTypes/CTypesISO + * + * (c) The FFI task force, 2000 + * -------------------------------------------------------------------------- */ + +#include "MachDeps.h" + +/* As long as there is no automatic derivation of classes for newtypes we resort + to extremely dirty cpp-hackery. :-P Some care has to be taken when the + macros below are modified, otherwise the layout rule will bite you. */ + +/* A hacked version for GHC follows the Haskell 98 version... */ +#ifndef __GLASGOW_HASKELL__ + +#define NUMERIC_TYPE(T,C,S,B) \ +newtype T = T B deriving (Eq, Ord) ; \ +INSTANCE_NUM(T) ; \ +INSTANCE_READ(T) ; \ +INSTANCE_SHOW(T) ; \ +INSTANCE_ENUM(T) ; \ +INSTANCE_TYPEABLE(T,C,S) ; + +#define INTEGRAL_TYPE(T,C,S,B) \ +NUMERIC_TYPE(T,C,S,B) ; \ +INSTANCE_BOUNDED(T) ; \ +INSTANCE_REAL(T) ; \ +INSTANCE_INTEGRAL(T) ; \ +INSTANCE_BITS(T) + +#define FLOATING_TYPE(T,C,S,B) \ +NUMERIC_TYPE(T,C,S,B) ; \ +INSTANCE_REAL(T) ; \ +INSTANCE_FRACTIONAL(T) ; \ +INSTANCE_FLOATING(T) ; \ +INSTANCE_REALFRAC(T) ; \ +INSTANCE_REALFLOAT(T) + +#define INSTANCE_READ(T) \ +instance Read T where { \ + readsPrec p s = fakeMap (\(x, t) -> (T x, t)) (readsPrec p s) } + +#define INSTANCE_SHOW(T) \ +instance Show T where { \ + showsPrec p (T x) = showsPrec p x } + +#define INSTANCE_NUM(T) \ +instance Num T where { \ + (T i) + (T j) = T (i + j) ; \ + (T i) - (T j) = T (i - j) ; \ + (T i) * (T j) = T (i * j) ; \ + negate (T i) = T (negate i) ; \ + abs (T i) = T (abs i) ; \ + signum (T i) = T (signum i) ; \ + fromInteger x = T (fromInteger x) } + +#define INSTANCE_TYPEABLE(T,C,S) \ +C :: TyCon ; \ +C = mkTyCon S ; \ +instance Typeable T where { \ + typeOf _ = mkAppTy C [] } + +#define INSTANCE_STORABLE(T) \ +instance Storable T where { \ + sizeOf (T x) = sizeOf x ; \ + alignment (T x) = alignment x ; \ + peekElemOff a i = liftM T (peekElemOff a i) ; \ + pokeElemOff a i (T x) = pokeElemOff a i x } + +#define INSTANCE_BOUNDED(T) \ +instance Bounded T where { \ + minBound = T minBound ; \ + maxBound = T maxBound } + +#define INSTANCE_ENUM(T) \ +instance Enum T where { \ + succ (T i) = T (succ i) ; \ + pred (T i) = T (pred i) ; \ + toEnum x = T (toEnum x) ; \ + fromEnum (T i) = fromEnum i ; \ + enumFrom (T i) = fakeMap T (enumFrom i) ; \ + enumFromThen (T i) (T j) = fakeMap T (enumFromThen i j) ; \ + enumFromTo (T i) (T j) = fakeMap T (enumFromTo i j) ; \ + enumFromThenTo (T i) (T j) (T k) = fakeMap T (enumFromThenTo i j k) } + +#define INSTANCE_REAL(T) \ +instance Real T where { \ + toRational (T i) = toRational i } + +#define INSTANCE_INTEGRAL(T) \ +instance Integral T where { \ + (T i) `quot` (T j) = T (i `quot` j) ; \ + (T i) `rem` (T j) = T (i `rem` j) ; \ + (T i) `div` (T j) = T (i `div` j) ; \ + (T i) `mod` (T j) = T (i `mod` j) ; \ + (T i) `quotRem` (T j) = let (q,r) = i `quotRem` j in (T q, T r) ; \ + (T i) `divMod` (T j) = let (d,m) = i `divMod` j in (T d, T m) ; \ + toInteger (T i) = toInteger i ; \ + toInt (T i) = toInt i } + +#define INSTANCE_BITS(T) \ +instance Bits T where { \ + (T x) .&. (T y) = T (x .&. y) ; \ + (T x) .|. (T y) = T (x .|. y) ; \ + (T x) `xor` (T y) = T (x `xor` y) ; \ + complement (T x) = T (complement x) ; \ + shift (T x) n = T (shift x n) ; \ + rotate (T x) n = T (rotate x n) ; \ + bit n = T (bit n) ; \ + setBit (T x) n = T (setBit x n) ; \ + clearBit (T x) n = T (clearBit x n) ; \ + complementBit (T x) n = T (complementBit x n) ; \ + testBit (T x) n = testBit x n ; \ + bitSize (T x) = bitSize x ; \ + isSigned (T x) = isSigned x } + +#define INSTANCE_FRACTIONAL(T) \ +instance Fractional T where { \ + (T x) / (T y) = T (x / y) ; \ + recip (T x) = T (recip x) ; \ + fromRational r = T (fromRational r) } + +#define INSTANCE_FLOATING(T) \ +instance Floating T where { \ + pi = pi ; \ + exp (T x) = T (exp x) ; \ + log (T x) = T (log x) ; \ + sqrt (T x) = T (sqrt x) ; \ + (T x) ** (T y) = T (x ** y) ; \ + (T x) `logBase` (T y) = T (x `logBase` y) ; \ + sin (T x) = T (sin x) ; \ + cos (T x) = T (cos x) ; \ + tan (T x) = T (tan x) ; \ + asin (T x) = T (asin x) ; \ + acos (T x) = T (acos x) ; \ + atan (T x) = T (atan x) ; \ + sinh (T x) = T (sinh x) ; \ + cosh (T x) = T (cosh x) ; \ + tanh (T x) = T (tanh x) ; \ + asinh (T x) = T (asinh x) ; \ + acosh (T x) = T (acosh x) ; \ + atanh (T x) = T (atanh x) } + +#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) \ +instance RealFloat T where { \ + floatRadix (T x) = floatRadix x ; \ + floatDigits (T x) = floatDigits x ; \ + floatRange (T x) = floatRange x ; \ + decodeFloat (T x) = decodeFloat x ; \ + encodeFloat m n = T (encodeFloat m n) ; \ + exponent (T x) = exponent x ; \ + significand (T x) = T (significand x) ; \ + scaleFloat n (T x) = T (scaleFloat n x) ; \ + isNaN (T x) = isNaN x ; \ + isInfinite (T x) = isInfinite x ; \ + isDenormalized (T x) = isDenormalized x ; \ + isNegativeZero (T x) = isNegativeZero x ; \ + isIEEE (T x) = isIEEE x ; \ + (T x) `atan2` (T y) = T (x `atan2` y) } + +#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). + */ + +#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) + +#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) + +#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); } + +#define INSTANCE_READ(T,B) \ +instance Read T where { \ + readsPrec = unsafeCoerce# (readsPrec :: Int -> ReadS B); \ + readList = unsafeCoerce# (readList :: ReadS [B]); } + +#define INSTANCE_SHOW(T,B) \ +instance Show T where { \ + showsPrec = unsafeCoerce# (showsPrec :: Int -> B -> ShowS); \ + 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); \ + fromInt = unsafeCoerce# (fromInt :: Int -> B) } + +#define INSTANCE_STORABLE(T,B) \ +instance Storable T where { \ + sizeOf = unsafeCoerce# (sizeOf :: B -> Int); \ + alignment = unsafeCoerce# (alignment :: B -> Int); \ + peekElemOff = unsafeCoerce# (peekElemOff :: Ptr B -> Int -> IO B); \ + pokeElemOff = unsafeCoerce# (pokeElemOff :: Ptr B -> Int -> B -> IO 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); \ + toInt = unsafeCoerce# (toInt:: B -> Int); } + +#define INSTANCE_BITS(T,B) \ +instance Bits T where { \ + (.&.) = unsafeCoerce# ((.&.) :: B -> B -> B); \ + (.|.) = unsafeCoerce# ((.|.) :: B -> B -> B); \ + xor = unsafeCoerce# (xor:: B -> B -> B); \ + complement = unsafeCoerce# (complement:: B -> B); \ + shift = unsafeCoerce# (shift:: B -> Int -> B); \ + rotate = unsafeCoerce# (rotate:: B -> Int -> B); \ + bit = unsafeCoerce# (bit:: Int -> B); \ + setBit = unsafeCoerce# (setBit:: B -> Int -> B); \ + clearBit = unsafeCoerce# (clearBit:: B -> Int -> B); \ + complementBit = unsafeCoerce# (complementBit:: B -> Int -> B); \ + testBit = unsafeCoerce# (testBit:: B -> Int -> Bool); \ + bitSize = unsafeCoerce# (bitSize:: B -> Int); \ + isSigned = unsafeCoerce# (isSigned:: B -> Bool); } + +#define INSTANCE_FRACTIONAL(T,B) \ +instance Fractional T where { \ + (/) = unsafeCoerce# ((/) :: B -> B -> B); \ + recip = unsafeCoerce# (recip :: B -> B); \ + fromRational = unsafeCoerce# (fromRational :: Rational -> B); } + +#define INSTANCE_FLOATING(T,B) \ +instance Floating T where { \ + pi = unsafeCoerce# (pi :: B); \ + exp = unsafeCoerce# (exp :: B -> B); \ + log = unsafeCoerce# (log :: B -> B); \ + sqrt = unsafeCoerce# (sqrt :: B -> B); \ + (**) = unsafeCoerce# ((**) :: B -> B -> B); \ + logBase = unsafeCoerce# (logBase :: B -> B -> B); \ + sin = unsafeCoerce# (sin :: B -> B); \ + cos = unsafeCoerce# (cos :: B -> B); \ + tan = unsafeCoerce# (tan :: B -> B); \ + asin = unsafeCoerce# (asin :: B -> B); \ + acos = unsafeCoerce# (acos :: B -> B); \ + atan = unsafeCoerce# (atan :: B -> B); \ + sinh = unsafeCoerce# (sinh :: B -> B); \ + cosh = unsafeCoerce# (cosh :: B -> B); \ + tanh = unsafeCoerce# (tanh :: B -> B); \ + asinh = unsafeCoerce# (asinh :: B -> B); \ + acosh = unsafeCoerce# (acosh :: B -> B); \ + atanh = unsafeCoerce# (atanh :: B -> B); } + +/* The coerce trick doesn't work for RealFrac, these methods are + * polymorphic and overloaded. + */ +#define INSTANCE_REALFRAC(T) \ +instance RealFrac T where { \ + properFraction (T x) = let (m,y) = properFraction x in (m, T y) ; \ + truncate (T x) = truncate x ; \ + round (T x) = round x ; \ + ceiling (T x) = ceiling x ; \ + floor (T x) = floor x } + +#define INSTANCE_REALFLOAT(T,B) \ +instance RealFloat T where { \ + floatRadix = unsafeCoerce# (floatRadix :: B -> Integer); \ + floatDigits = unsafeCoerce# (floatDigits :: B -> Int); \ + floatRange = unsafeCoerce# (floatRange :: B -> (Int,Int)); \ + decodeFloat = unsafeCoerce# (decodeFloat :: B -> (Integer,Int)); \ + encodeFloat = unsafeCoerce# (encodeFloat :: Integer -> Int -> B); \ + exponent = unsafeCoerce# (exponent :: B -> Int); \ + significand = unsafeCoerce# (significand :: B -> B); \ + scaleFloat = unsafeCoerce# (scaleFloat :: Int -> B -> B); \ + isNaN = unsafeCoerce# (isNaN :: B -> Bool); \ + isInfinite = unsafeCoerce# (isInfinite :: B -> Bool); \ + isDenormalized = unsafeCoerce# (isDenormalized :: B -> Bool); \ + isNegativeZero = unsafeCoerce# (isNegativeZero :: B -> Bool); \ + isIEEE = unsafeCoerce# (isIEEE :: B -> Bool); \ + atan2 = unsafeCoerce# (atan2 :: B -> B -> B); } + +#endif /* __GLASGOW_HASKELL__ */ diff --git a/ghc/lib/std/cbits/createDirectory.c b/ghc/lib/std/cbits/createDirectory.c deleted file mode 100644 index 389a293..0000000 --- a/ghc/lib/std/cbits/createDirectory.c +++ /dev/null @@ -1,63 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: createDirectory.c,v 1.4 1999/03/01 09:03:37 sof Exp $ - * - * createDirectory Runtime Support} - */ - -#include "Rts.h" -#include "stgio.h" - -#ifdef HAVE_SYS_TYPES_H -#include -#endif - -#ifdef HAVE_SYS_STAT_H -#include -#endif - -#if defined(mingw32_TARGET_OS) -#define mkDir(nm,p) mkdir(nm) -#else -#define mkDir(nm,p) mkdir(nm,p) -#endif - -StgInt -createDirectory(path) -StgByteArray path; -{ - int rc; - struct stat sb; - - while((rc = mkDir(path, 0777)) != 0) { - if (errno != EINTR) { - cvtErrno(); - switch (ghc_errno) { - default: - stdErrno(); - break; - case GHC_ENOENT: - case GHC_ENOTDIR: - ghc_errtype = ERR_NOSUCHTHING; - ghc_errstr = "no path to directory"; - break; - case GHC_EEXIST: - if (stat(path, &sb) != 0) { - ghc_errtype = ERR_OTHERERROR; - ghc_errstr = "cannot stat existing file"; - } - if (S_ISDIR(sb.st_mode)) { - ghc_errtype = ERR_ALREADYEXISTS; - ghc_errstr = "directory already exists"; - } else { - ghc_errtype = ERR_INAPPROPRIATETYPE; - ghc_errstr = "file already exists"; - } - break; - } - return -1; - } - } - return 0; -} diff --git a/ghc/lib/std/cbits/directoryAux.c b/ghc/lib/std/cbits/directoryAux.c deleted file mode 100644 index 1aa52ac..0000000 --- a/ghc/lib/std/cbits/directoryAux.c +++ /dev/null @@ -1,128 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1998 - * - * $Id: directoryAux.c,v 1.3 2000/08/24 10:27:01 simonmar Exp $ - * - * Support functions for manipulating directories - */ - -#include "Rts.h" -#include "stgio.h" - -#ifdef HAVE_SYS_TYPES_H -#include -#endif - -#ifdef HAVE_SYS_STAT_H -#include -#endif - -#ifdef HAVE_DIRENT_H -#include -#endif - -StgAddr -openDir__(StgByteArray path) -{ - struct stat sb; - DIR *dir; - - /* Check for an actual directory */ - while (stat(path, &sb) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return NULL; - } - } - if (!S_ISDIR(sb.st_mode)) { - ghc_errtype = ERR_INAPPROPRIATETYPE; - ghc_errstr = "not a directory"; - return NULL; - } - - while ((dir = opendir(path)) == NULL) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return NULL; - } - } - return dir; -} - -StgAddr -readDir__(StgAddr dir) - -{ - struct dirent *d; - while ((d = readdir((DIR*)dir)) == NULL) { - if (errno == 0) { - (void) closedir((DIR*)dir); - return NULL; - } else if (errno != EINTR) { - cvtErrno(); - stdErrno(); - (void) closedir((DIR*)dir); - return NULL; - } - errno = 0; - } - return d; -} - -StgAddr -get_dirent_d_name(StgAddr d) -{ - return ((struct dirent*)d)->d_name; -} - -StgInt sizeof_stat( void ) { return sizeof(struct stat); } - -StgInt prim_stat(StgAddr x, StgAddr y) -{ - return stat((char*)x, (struct stat*)y); -} - - -StgWord -get_stat_st_mode (StgAddr x) -{ - return ((struct stat *)x)->st_mode; -} - - -StgInt64 -get_stat_st_mtime(StgAddr x) -{ - return ((struct stat *)x)->st_mtime; -} - -void -set_stat_st_mtime(StgByteArray p, StgByteArray x) -{ - ((unsigned long *)p)[0] = ((struct stat *)x)->st_mtime; - return; -} - -StgWord const_S_IRUSR( void ) { return S_IRUSR; } -StgWord const_S_IWUSR( void ) { return S_IWUSR; } -StgWord const_S_IXUSR( void ) { return S_IXUSR; } - -StgInt -prim_S_ISDIR( StgWord x ) -{ - return S_ISDIR(x); -} - -StgInt -prim_S_ISREG( StgWord x ) -{ - return S_ISREG(x); -} - - -StgWord const_R_OK( void ) { return R_OK; } -StgWord const_W_OK( void ) { return W_OK; } -StgWord const_X_OK( void ) { return X_OK; } -StgWord const_F_OK( void ) { return F_OK; } diff --git a/ghc/lib/std/cbits/getCurrentDirectory.c b/ghc/lib/std/cbits/getCurrentDirectory.c deleted file mode 100644 index a5271dd..0000000 --- a/ghc/lib/std/cbits/getCurrentDirectory.c +++ /dev/null @@ -1,47 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: getCurrentDirectory.c,v 1.3 1998/12/02 13:27:39 simonm Exp $ - * - * getCurrentDirectory Runtime Support - */ - -#include "Rts.h" -#include "stgio.h" - -#ifndef PATH_MAX -#ifdef MAXPATHLEN -#define PATH_MAX MAXPATHLEN -#else -#define PATH_MAX 1024 -#endif -#endif - -StgAddr -getCurrentDirectory(void) -{ - char *pwd; - int alloc; - - alloc = PATH_MAX; - if ((pwd = malloc(alloc)) == NULL) { - ghc_errtype = ERR_RESOURCEEXHAUSTED; - ghc_errstr = "not enough virtual memory"; - return NULL; - } - while (getcwd(pwd, alloc) == NULL) { - if (errno == ERANGE) { - alloc += PATH_MAX; - if ((pwd = realloc(pwd, alloc)) == NULL) { - ghc_errtype = ERR_RESOURCEEXHAUSTED; - ghc_errstr = "not enough virtual memory"; - return NULL; - } - } else if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return NULL; - } - } - return (StgAddr) pwd; -} diff --git a/ghc/lib/std/cbits/getDirectoryContents.c b/ghc/lib/std/cbits/getDirectoryContents.c deleted file mode 100644 index c4a2b7e..0000000 --- a/ghc/lib/std/cbits/getDirectoryContents.c +++ /dev/null @@ -1,125 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: getDirectoryContents.c,v 1.3 1998/12/02 13:27:40 simonm Exp $ - * - * getDirectoryContents Runtime Support - */ - -#include "Rts.h" -#include "stgio.h" - -#ifdef HAVE_SYS_TYPES_H -#include -#endif - -#ifdef HAVE_SYS_STAT_H -#include -#endif - -#ifdef HAVE_DIRENT_H -#include -#endif - -#ifndef LINK_MAX -#define LINK_MAX 1024 -#endif - -/* For cleanup of partial answer on error */ - -static void -freeEntries(char **entries, int count) -{ - int i; - - for (i = 0; i < count; i++) - free(entries[i]); - free(entries); -} - -/* - * Our caller expects a malloc'ed array of malloc'ed string pointers. - * To ensure consistency when mixing this with other directory - * operations, we collect the entire list in one atomic operation, - * rather than reading the directory lazily. - */ -StgAddr -getDirectoryContents(path) -StgByteArray path; -{ - struct stat sb; - DIR *dir; - struct dirent *d; - char **entries; - int alloc, count, len; - - /* Check for an actual directory */ - while (stat(path, &sb) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return NULL; - } - } - if (!S_ISDIR(sb.st_mode)) { - ghc_errtype = ERR_INAPPROPRIATETYPE; - ghc_errstr = "not a directory"; - return NULL; - } - - alloc = LINK_MAX; - if ((entries = (char **) malloc(alloc * sizeof(char *))) == NULL) { - ghc_errtype = ERR_RESOURCEEXHAUSTED; - ghc_errstr = "not enough virtual memory"; - return NULL; - } - - while ((dir = opendir(path)) == NULL) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - free(entries); - return NULL; - } - } - - count = 0; - for (;;) { - errno = 0; /* unchanged by readdir on EOF */ - while ((d = readdir(dir)) == NULL) { - if (errno == 0) { - entries[count] = NULL; - (void) closedir(dir); - return (StgAddr) entries; - } else if (errno != EINTR) { - cvtErrno(); - stdErrno(); - freeEntries(entries, count); - (void) closedir(dir); - return NULL; - } - errno = 0; - } - len = strlen(d->d_name); - if ((entries[count] = malloc(len+1)) == NULL) { - ghc_errtype = ERR_RESOURCEEXHAUSTED; - ghc_errstr = "not enough virtual memory"; - freeEntries(entries, count); - (void) closedir(dir); - return NULL; - } - strcpy(entries[count], d->d_name); - /* Terminate the sucker */ - *(entries[count] + len) = 0; - if (++count == alloc) { - alloc += LINK_MAX; - if ((entries = (char **) realloc(entries, alloc * sizeof(char *))) == NULL) { - ghc_errtype = ERR_RESOURCEEXHAUSTED; - ghc_errstr = "not enough virtual memory"; - freeEntries(entries, count); - (void) closedir(dir); - return NULL; - } - } - } -} diff --git a/ghc/lib/std/cbits/progargs.c b/ghc/lib/std/cbits/progargs.c index 30d89aa..b0ee172 100644 --- a/ghc/lib/std/cbits/progargs.c +++ b/ghc/lib/std/cbits/progargs.c @@ -1,7 +1,7 @@ /* * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 * - * $Id: progargs.c,v 1.3 2000/03/14 01:52:25 sof Exp $ + * $Id: progargs.c,v 1.4 2001/01/11 17:25:58 simonmar Exp $ * * System.getArgs Runtime Support */ @@ -9,13 +9,13 @@ #include "Rts.h" #include "stgio.h" -StgAddr +HsAddr get_prog_argv(void) { return prog_argv; } -StgInt +HsInt get_prog_argc() { return prog_argc; diff --git a/ghc/lib/std/cbits/removeDirectory.c b/ghc/lib/std/cbits/removeDirectory.c deleted file mode 100644 index 21864a3..0000000 --- a/ghc/lib/std/cbits/removeDirectory.c +++ /dev/null @@ -1,56 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: removeDirectory.c,v 1.3 1998/12/02 13:27:47 simonm Exp $ - * - * removeDirectory Runtime Support - */ - -#include "Rts.h" -#include "stgio.h" - -#ifdef HAVE_SYS_TYPES_H -#include -#endif - -#ifdef HAVE_SYS_STAT_H -#include -#endif - -StgInt -removeDirectory(path) -StgByteArray path; -{ - struct stat sb; - - /* Check for an actual directory */ - while (stat(path, &sb) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - if (!S_ISDIR(sb.st_mode)) { - ghc_errtype = ERR_INAPPROPRIATETYPE; - ghc_errstr = "not a directory"; - return -1; - } - while (rmdir(path) != 0) { - if (errno != EINTR) { - cvtErrno(); - switch (ghc_errno) { - default: - stdErrno(); - break; - case GHC_ENOTEMPTY: - case GHC_EEXIST: - ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS; - ghc_errstr = "directory not empty"; - break; - } - return -1; - } - } - return 0; -} diff --git a/ghc/lib/std/cbits/removeFile.c b/ghc/lib/std/cbits/removeFile.c deleted file mode 100644 index 22e9a7b..0000000 --- a/ghc/lib/std/cbits/removeFile.c +++ /dev/null @@ -1,46 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: removeFile.c,v 1.4 2000/04/06 10:33:07 rrt Exp $ - * - * removeFile Runtime Support - */ - -#include "Rts.h" -#include "stgio.h" - -#ifdef HAVE_SYS_TYPES_H -#include -#endif - -#ifdef HAVE_SYS_STAT_H -#include -#endif - -StgInt -removeFile(StgByteArray path) -{ - struct stat sb; - - /* Check for a non-directory */ - while (stat(path, &sb) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - if (S_ISDIR(sb.st_mode)) { - ghc_errtype = ERR_INAPPROPRIATETYPE; - ghc_errstr = "file is a directory"; - return -1; - } - while (unlink(path) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - return 0; -} diff --git a/ghc/lib/std/cbits/renameDirectory.c b/ghc/lib/std/cbits/renameDirectory.c deleted file mode 100644 index 68b1560..0000000 --- a/ghc/lib/std/cbits/renameDirectory.c +++ /dev/null @@ -1,48 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: renameDirectory.c,v 1.3 1998/12/02 13:27:50 simonm Exp $ - * - * renameDirectory Runtime Support - */ - -#include "Rts.h" -#include "stgio.h" - -#ifdef HAVE_SYS_TYPES_H -#include -#endif - -#ifdef HAVE_SYS_STAT_H -#include -#endif - -StgInt -renameDirectory(opath, npath) -StgByteArray opath; -StgByteArray npath; -{ - struct stat sb; - - /* Check for an actual directory */ - while (stat(opath, &sb) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - if (!S_ISDIR(sb.st_mode)) { - ghc_errtype = ERR_INAPPROPRIATETYPE; - ghc_errstr = "not a directory"; - return -1; - } - while(rename(opath, npath) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - return 0; -} diff --git a/ghc/lib/std/cbits/renameFile.c b/ghc/lib/std/cbits/renameFile.c deleted file mode 100644 index 2126849..0000000 --- a/ghc/lib/std/cbits/renameFile.c +++ /dev/null @@ -1,84 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: renameFile.c,v 1.8 2000/04/06 10:33:06 rrt Exp $ - * - * renameFile Runtime Support - */ - -#include "Rts.h" -#include "stgio.h" - -#ifdef HAVE_SYS_TYPES_H -#include -#endif - -#ifdef HAVE_SYS_STAT_H -#include -#endif - -#ifdef HAVE_FCNTL_H -#include -#endif - - -StgInt -renameFile(StgByteArray opath, StgByteArray npath) -{ - struct stat sb; - - /* Check for a non-directory source */ - while (stat(opath, &sb) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - if (S_ISDIR(sb.st_mode)) { - ghc_errtype = ERR_INAPPROPRIATETYPE; - ghc_errstr = "file is a directory"; - return -1; - } - - /* Check for a non-directory destination */ - while (stat(npath, &sb) != 0 && errno != ENOENT) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - - if (errno != ENOENT) { - if (S_ISDIR(sb.st_mode)) { - ghc_errtype = ERR_INAPPROPRIATETYPE; - ghc_errstr = "file is a directory"; - return -1; - } - while (chmod(npath, S_IWUSR) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - while (unlink(npath) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - } - - while(rename(opath, npath) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - - return 0; -} diff --git a/ghc/lib/std/cbits/setCurrentDirectory.c b/ghc/lib/std/cbits/setCurrentDirectory.c deleted file mode 100644 index 9c86cd7..0000000 --- a/ghc/lib/std/cbits/setCurrentDirectory.c +++ /dev/null @@ -1,24 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: setCurrentDirectory.c,v 1.3 1998/12/02 13:27:56 simonm Exp $ - * - * setCurrentDirectory Runtime Support - */ - -#include "Rts.h" -#include "stgio.h" - -StgInt -setCurrentDirectory(path) -StgByteArray path; -{ - while (chdir(path) != 0) { - if (errno != EINTR) { - cvtErrno(); - stdErrno(); - return -1; - } - } - return 0; -} diff --git a/ghc/rts/Prelude.h b/ghc/rts/Prelude.h index c2f6ca9..e2c0457 100644 --- a/ghc/rts/Prelude.h +++ b/ghc/rts/Prelude.h @@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- - * $Id: Prelude.h,v 1.12 2000/07/07 11:03:57 simonmar Exp $ + * $Id: Prelude.h,v 1.13 2001/01/11 17:25:56 simonmar Exp $ * - * (c) The GHC Team, 1998-2000 + * (c) The GHC Team, 1998-2001 * * Prelude identifiers that we sometimes need to refer to in the RTS. * @@ -11,7 +11,7 @@ #define PRELUDE_H /* Define canonical names so we can abstract away from the actual - * module these names are defined in. + * modules these names are defined in. */ #ifndef INTERPRETER @@ -31,16 +31,32 @@ extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info; extern DLL_IMPORT const StgInfoTable PrelBase_Izh_static_info; extern DLL_IMPORT const StgInfoTable PrelFloat_Fzh_static_info; extern DLL_IMPORT const StgInfoTable PrelFloat_Dzh_static_info; -extern DLL_IMPORT const StgInfoTable PrelAddr_Azh_static_info; -extern DLL_IMPORT const StgInfoTable PrelAddr_Wzh_static_info; +extern DLL_IMPORT const StgInfoTable Addr_Azh_static_info; +extern DLL_IMPORT const StgInfoTable PrelPtr_Ptr_static_info; +extern DLL_IMPORT const StgInfoTable PrelInt_I8zh_static_info; +extern DLL_IMPORT const StgInfoTable PrelInt_I16zh_static_info; +extern DLL_IMPORT const StgInfoTable PrelInt_I32zh_static_info; +extern DLL_IMPORT const StgInfoTable PrelInt_I64zh_static_info; +extern DLL_IMPORT const StgInfoTable PrelWord_Wzh_static_info; +extern DLL_IMPORT const StgInfoTable PrelWord_W8zh_static_info; +extern DLL_IMPORT const StgInfoTable PrelWord_W16zh_static_info; +extern DLL_IMPORT const StgInfoTable PrelWord_W32zh_static_info; +extern DLL_IMPORT const StgInfoTable PrelWord_W64zh_static_info; extern DLL_IMPORT const StgInfoTable PrelBase_Czh_con_info; extern DLL_IMPORT const StgInfoTable PrelBase_Izh_con_info; extern DLL_IMPORT const StgInfoTable PrelFloat_Fzh_con_info; extern DLL_IMPORT const StgInfoTable PrelFloat_Dzh_con_info; -extern DLL_IMPORT const StgInfoTable PrelAddr_Azh_con_info; -extern DLL_IMPORT const StgInfoTable PrelAddr_Wzh_con_info; -extern DLL_IMPORT const StgInfoTable PrelAddr_I64zh_con_info; -extern DLL_IMPORT const StgInfoTable PrelAddr_W64zh_con_info; +extern DLL_IMPORT const StgInfoTable PrelPtr_Ptr_con_info; +extern DLL_IMPORT const StgInfoTable Addr_Azh_con_info; +extern DLL_IMPORT const StgInfoTable PrelWord_Wzh_con_info; +extern DLL_IMPORT const StgInfoTable PrelInt_I8zh_con_info; +extern DLL_IMPORT const StgInfoTable PrelInt_I16zh_con_info; +extern DLL_IMPORT const StgInfoTable PrelInt_I32zh_con_info; +extern DLL_IMPORT const StgInfoTable PrelInt_I64zh_con_info; +extern DLL_IMPORT const StgInfoTable PrelWord_W8zh_con_info; +extern DLL_IMPORT const StgInfoTable PrelWord_W16zh_con_info; +extern DLL_IMPORT const StgInfoTable PrelWord_W32zh_con_info; +extern DLL_IMPORT const StgInfoTable PrelWord_W64zh_con_info; extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_static_info; extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info; @@ -57,19 +73,36 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info; #define NonTermination_closure (&PrelIOBase_NonTermination_closure) #define Czh_static_info (&PrelBase_Czh_static_info) -#define Izh_static_info (&PrelBase_Izh_static_info) #define Fzh_static_info (&PrelFloat_Fzh_static_info) #define Dzh_static_info (&PrelFloat_Dzh_static_info) -#define Azh_static_info (&PrelAddr_Azh_static_info) -#define Wzh_static_info (&PrelAddr_Wzh_static_info) +#define Azh_static_info (&Addr_Azh_static_info) +#define Izh_static_info (&PrelBase_Izh_static_info) +#define I8zh_static_info (&PrelInt_I8zh_static_info) +#define I16zh_static_info (&PrelInt_I16zh_static_info) +#define I32zh_static_info (&PrelInt_I32zh_static_info) +#define I64zh_static_info (&PrelInt_I64zh_static_info) +#define Wzh_static_info (&PrelWord_Wzh_static_info) +#define W8zh_static_info (&PrelWord_W8zh_static_info) +#define W16zh_static_info (&PrelWord_W16zh_static_info) +#define W32zh_static_info (&PrelWord_W32zh_static_info) +#define W64zh_static_info (&PrelWord_W64zh_static_info) +#define Ptr_static_info (&PrelPtr_Ptr_static_info) #define Czh_con_info (&PrelBase_Czh_con_info) #define Izh_con_info (&PrelBase_Izh_con_info) #define Fzh_con_info (&PrelFloat_Fzh_con_info) #define Dzh_con_info (&PrelFloat_Dzh_con_info) -#define Azh_con_info (&PrelAddr_Azh_con_info) -#define Wzh_con_info (&PrelAddr_Wzh_con_info) -#define W64zh_con_info (&PrelAddr_W64zh_con_info) -#define I64zh_con_info (&PrelAddr_I64zh_con_info) +#define Azh_con_info (&Addr_Azh_con_info) +#define Wzh_con_info (&PrelWord_Wzh_con_info) +#define W8zh_con_info (&PrelWord_W8zh_con_info) +#define W16zh_con_info (&PrelWord_W16zh_con_info) +#define W32zh_con_info (&PrelWord_W32zh_con_info) +#define W64zh_con_info (&PrelWord_W64zh_con_info) +#define I8zh_con_info (&PrelInt_I8zh_con_info) +#define I16zh_con_info (&PrelInt_I16zh_con_info) +#define I32zh_con_info (&PrelInt_I32zh_con_info) +#define I64zh_con_info (&PrelInt_I64zh_con_info) +#define I64zh_con_info (&PrelInt_I64zh_con_info) +#define Ptr_con_info (&PrelPtr_Ptr_con_info) #define StablePtr_static_info (&PrelStable_StablePtr_static_info) #define StablePtr_con_info (&PrelStable_StablePtr_con_info) diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c index 1cb0aee..8e03d7d 100644 --- a/ghc/rts/RtsAPI.c +++ b/ghc/rts/RtsAPI.c @@ -1,7 +1,7 @@ /* ---------------------------------------------------------------------------- - * $Id: RtsAPI.c,v 1.23 2000/12/04 12:31:21 simonmar Exp $ + * $Id: RtsAPI.c,v 1.24 2001/01/11 17:25:56 simonmar Exp $ * - * (c) The GHC Team, 1998-2000 + * (c) The GHC Team, 1998-2001 * * API for invoking Haskell functions via the RTS * @@ -40,11 +40,7 @@ HaskellObj rts_mkInt8 (HsInt8 i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - /* This is a 'cheat', using the static info table for Ints, - instead of the one for Int8, but the types have identical - representation. - */ - p->header.info = Izh_con_info; + p->header.info = I8zh_con_info; /* Make sure we mask out the bits above the lowest 8 */ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff); return p; @@ -54,11 +50,7 @@ HaskellObj rts_mkInt16 (HsInt16 i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - /* This is a 'cheat', using the static info table for Ints, - instead of the one for Int8, but the types have identical - representation. - */ - p->header.info = Izh_con_info; + p->header.info = I16zh_con_info; /* Make sure we mask out the relevant bits */ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff); return p; @@ -68,8 +60,7 @@ HaskellObj rts_mkInt32 (HsInt32 i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - /* see mk_Int8 comment */ - p->header.info = Izh_con_info; + p->header.info = I32zh_con_info; p->payload[0] = (StgClosure *)(StgInt)i; return p; } @@ -79,7 +70,6 @@ rts_mkInt64 (HsInt64 i) { long long *tmp; StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2)); - /* see mk_Int8 comment */ p->header.info = I64zh_con_info; tmp = (long long*)&(p->payload[0]); *tmp = (StgInt64)i; @@ -100,7 +90,7 @@ rts_mkWord8 (HsWord8 w) { /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = Wzh_con_info; + p->header.info = W8zh_con_info; p->payload[0] = (StgClosure *)(StgWord)(w & 0xff); return p; } @@ -110,7 +100,7 @@ rts_mkWord16 (HsWord16 w) { /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = Wzh_con_info; + p->header.info = W16zh_con_info; p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff); return p; } @@ -120,7 +110,7 @@ rts_mkWord32 (HsWord32 w) { /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = Wzh_con_info; + p->header.info = W32zh_con_info; p->payload[0] = (StgClosure *)(StgWord)w; return p; } @@ -166,10 +156,10 @@ rts_mkStablePtr (HsStablePtr s) } HaskellObj -rts_mkAddr (HsAddr a) +rts_mkPtr (HsPtr a) { StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1); - p->header.info = Azh_con_info; + p->header.info = Ptr_con_info; p->payload[0] = (StgClosure *)a; return p; } @@ -188,7 +178,7 @@ rts_mkBool (HsBool b) HaskellObj rts_mkString (char *s) { - return rts_apply((StgClosure *)unpackCString_closure, rts_mkAddr(s)); + return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s)); } #endif /* COMPILER */ @@ -234,8 +224,8 @@ HsInt32 rts_getInt32 (HaskellObj p) { if ( 1 || - p->header.info == Izh_con_info || - p->header.info == Izh_static_info ) { + p->header.info == I32zh_con_info || + p->header.info == I32zh_static_info ) { return (int)(p->payload[0]); } else { barf("getInt: not an Int"); @@ -258,8 +248,8 @@ HsWord32 rts_getWord32 (HaskellObj p) { if ( 1 || /* see above comment */ - p->header.info == Wzh_con_info || - p->header.info == Wzh_static_info ) { + p->header.info == W32zh_con_info || + p->header.info == W32zh_static_info ) { return (unsigned int)(p->payload[0]); } else { barf("getWord: not a Word"); @@ -299,15 +289,14 @@ rts_getStablePtr (HaskellObj p) } } -HsAddr -rts_getAddr (HaskellObj p) +HsPtr +rts_getPtr (HaskellObj p) { - if ( p->header.info == Azh_con_info || - p->header.info == Azh_static_info ) { - + if ( p->header.info == Ptr_con_info || + p->header.info == Ptr_static_info ) { return (void *)(p->payload[0]); } else { - barf("getAddr: not an Addr"); + barf("getPtr: not an Ptr"); } } diff --git a/ghc/rts/RtsAPIDeprec.c b/ghc/rts/RtsAPIDeprec.c new file mode 100644 index 0000000..45d9ba2 --- /dev/null +++ b/ghc/rts/RtsAPIDeprec.c @@ -0,0 +1,34 @@ +/* ---------------------------------------------------------------------------- + * $Id: RtsAPIDeprec.c,v 1.1 2001/01/11 17:25:56 simonmar Exp $ + * + * (c) The GHC Team, 1998-2001 + * + * RTS API functions that are deprecated + * + * --------------------------------------------------------------------------*/ + +#include "Rts.h" +#include "RtsUtils.h" +#include "Storage.h" +#include "Prelude.h" + +HaskellObj +rts_mkAddr (HsAddr a) +{ + StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1); + p->header.info = Azh_con_info; + p->payload[0] = (StgClosure *)a; + return p; +} + +HsAddr +rts_getAddr (HaskellObj p) +{ + if ( p->header.info == Azh_con_info || + p->header.info == Azh_static_info ) { + + return (void *)(p->payload[0]); + } else { + barf("getAddr: not an Addr"); + } +} -- 1.7.10.4