ghc/lib/std/PrelStorable.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: PrelStorable.lhs,v 1.5 2001/04/13 21:37:43 panne Exp $
   3 %
   4 % (c) The FFI task force, 2000
   5 %
   6
   7 A class for primitive marshaling
   8
   9 \begin{code}
  10 #include "MachDeps.h"
  11
  12 module PrelStorable
  13         ( Storable(
  14              sizeOf,         -- :: a -> Int
  15              alignment,      -- :: a -> Int
  16              peekElemOff,    -- :: Ptr a -> Int      -> IO a
  17              pokeElemOff,    -- :: Ptr a -> Int -> a -> IO ()
  18              peekByteOff,    -- :: Ptr b -> Int      -> IO a
  19              pokeByteOff,    -- :: Ptr b -> Int -> a -> IO ()
  20              peek,           -- :: Ptr a             -> IO a
  21              poke,           -- :: Ptr a        -> a -> IO ()
  22              destruct)       -- :: Ptr a             -> IO ()
  23         ) where
  24 \end{code}
  25
  26 \begin{code}
  27 import Char             ( chr, ord )
  28 import Monad            ( liftM )
  29
  30 #ifdef __GLASGOW_HASKELL__
  31 import PrelStable       ( StablePtr )
  32 import PrelInt
  33 import PrelWord
  34 import PrelCTypes
  35 import PrelCTypesISO
  36 import PrelStable
  37 import PrelPtr
  38 import PrelFloat
  39 import PrelIOBase
  40 import PrelBase
  41 #endif
  42 \end{code}
  43
  44 Primitive marshaling
  45
  46 Minimal complete definition: sizeOf, alignment, and one definition
  47 in each of the peek/poke families.
  48
  49 \begin{code}
  50 class Storable a where
  51
  52    -- sizeOf/alignment *never* use their first argument
  53    sizeOf      :: a -> Int
  54    alignment   :: a -> Int
  55
  56    -- replacement for read-/write???OffAddr
  57    peekElemOff :: Ptr a -> Int      -> IO a
  58    pokeElemOff :: Ptr a -> Int -> a -> IO ()
  59
  60    -- the same with *byte* offsets
  61    peekByteOff :: Ptr b -> Int      -> IO a
  62    pokeByteOff :: Ptr b -> Int -> a -> IO ()
  63
  64    -- ... and with no offsets at all
  65    peek        :: Ptr a      -> IO a
  66    poke        :: Ptr a -> a -> IO ()
  67
  68    -- free memory associated with the object
  69    -- (except the object pointer itself)
  70    destruct    :: Ptr a -> IO ()
  71
  72    -- circular default instances
  73    peekElemOff = peekElemOff_ undefined
  74       where peekElemOff_ :: a -> Ptr a -> Int -> IO a
  75             peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)
  76    pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val
  77
  78    peekByteOff ptr off = peek (ptr `plusPtr` off)
  79    pokeByteOff ptr off = poke (ptr `plusPtr` off)
  80
  81    peek ptr = peekElemOff ptr 0
  82    poke ptr = pokeElemOff ptr 0
  83
  84    destruct _ = return ()
  85 \end{code}
  86
  87 System-dependent, but rather obvious instances
  88
  89 \begin{code}
  90 instance Storable Bool where
  91    sizeOf _          = sizeOf (undefined::CInt)
  92    alignment _       = alignment (undefined::CInt)
  93    peekElemOff p i   = liftM (/= (0::CInt)) $ peekElemOff (castPtr p) i
  94    pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::CInt)
  95
  96 #define STORABLE(T,size,align,read,write)       \
  97 instance Storable (T) where {                   \
  98     sizeOf    _ = size;                         \
  99     alignment _ = align;                        \
 100     peekElemOff = read;                         \
 101     pokeElemOff = write }
 102
 103 STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32,
 104          readWideCharOffPtr,writeWideCharOffPtr)
 105
 106 STORABLE(Int,SIZEOF_LONG,ALIGNMENT_LONG,
 107          readIntOffPtr,writeIntOffPtr)
 108
 109 STORABLE(Word,SIZEOF_LONG,ALIGNMENT_LONG,
 110          readWordOffPtr,writeWordOffPtr)
 111
 112 STORABLE((Ptr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
 113          readPtrOffPtr,writePtrOffPtr)
 114
 115 STORABLE((FunPtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
 116          readFunPtrOffPtr,writeFunPtrOffPtr)
 117
 118 STORABLE((StablePtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
 119          readStablePtrOffPtr,writeStablePtrOffPtr)
 120
 121 STORABLE(Float,SIZEOF_FLOAT,ALIGNMENT_FLOAT,
 122          readFloatOffPtr,writeFloatOffPtr)
 123
 124 STORABLE(Double,SIZEOF_DOUBLE,ALIGNMENT_DOUBLE,
 125          readDoubleOffPtr,writeDoubleOffPtr)
 126
 127 STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8,
 128          readWord8OffPtr,writeWord8OffPtr)
 129
 130 STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16,
 131          readWord16OffPtr,writeWord16OffPtr)
 132
 133 STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32,
 134          readWord32OffPtr,writeWord32OffPtr)
 135
 136 STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64,
 137          readWord64OffPtr,writeWord64OffPtr)
 138
 139 STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8,
 140          readInt8OffPtr,writeInt8OffPtr)
 141
 142 STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16,
 143          readInt16OffPtr,writeInt16OffPtr)
 144
 145 STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,
 146          readInt32OffPtr,writeInt32OffPtr)
 147
 148 STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,
 149          readInt64OffPtr,writeInt64OffPtr)
 150
 151 #define NSTORABLE(T) \
 152 instance Storable T where { \
 153    sizeOf    (T x)       = sizeOf x ; \
 154    alignment (T x)       = alignment x ; \
 155    peekElemOff a i       = liftM T (peekElemOff (castPtr a) i) ; \
 156    pokeElemOff a i (T x) = pokeElemOff (castPtr a) i x }
 157
 158 NSTORABLE(CChar)
 159 NSTORABLE(CSChar)
 160 NSTORABLE(CUChar)
 161 NSTORABLE(CShort)
 162 NSTORABLE(CUShort)
 163 NSTORABLE(CInt)
 164 NSTORABLE(CUInt)
 165 NSTORABLE(CLong)
 166 NSTORABLE(CULong)
 167 NSTORABLE(CLLong)
 168 NSTORABLE(CULLong)
 169 NSTORABLE(CFloat)
 170 NSTORABLE(CDouble)
 171 NSTORABLE(CLDouble)
 172 NSTORABLE(CPtrdiff)
 173 NSTORABLE(CSize)
 174 NSTORABLE(CWchar)
 175 NSTORABLE(CSigAtomic)
 176 NSTORABLE(CClock)
 177 NSTORABLE(CTime)
 178 \end{code}
 179
 180 Helper functions
 181
 182 \begin{code}
 183 #ifdef __GLASGOW_HASKELL__
 184
 185 readWideCharOffPtr  :: Ptr Char          -> Int -> IO Char
 186 readIntOffPtr       :: Ptr Int           -> Int -> IO Int
 187 readWordOffPtr      :: Ptr Word          -> Int -> IO Word
 188 readPtrOffPtr       :: Ptr (Ptr a)       -> Int -> IO (Ptr a)
 189 readFunPtrOffPtr    :: Ptr (FunPtr a)    -> Int -> IO (FunPtr a)
 190 readFloatOffPtr     :: Ptr Float         -> Int -> IO Float
 191 readDoubleOffPtr    :: Ptr Double        -> Int -> IO Double
 192 readStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> IO (StablePtr a)
 193 readInt8OffPtr      :: Ptr Int8          -> Int -> IO Int8
 194 readInt16OffPtr     :: Ptr Int16         -> Int -> IO Int16
 195 readInt32OffPtr     :: Ptr Int32         -> Int -> IO Int32
 196 readInt64OffPtr     :: Ptr Int64         -> Int -> IO Int64
 197 readWord8OffPtr     :: Ptr Word8         -> Int -> IO Word8
 198 readWord16OffPtr    :: Ptr Word16        -> Int -> IO Word16
 199 readWord32OffPtr    :: Ptr Word32        -> Int -> IO Word32
 200 readWord64OffPtr    :: Ptr Word64        -> Int -> IO Word64
 201
 202 readWideCharOffPtr (Ptr a) (I# i)
 203   = IO $ \s -> case readWideCharOffAddr# a i s  of (# s2, x #) -> (# s2, C# x #)
 204 readIntOffPtr (Ptr a) (I# i)
 205   = IO $ \s -> case readIntOffAddr# a i s       of (# s2, x #) -> (# s2, I# x #)
 206 readWordOffPtr (Ptr a) (I# i)
 207   = IO $ \s -> case readWordOffAddr# a i s      of (# s2, x #) -> (# s2, W# x #)
 208 readPtrOffPtr (Ptr a) (I# i)
 209   = IO $ \s -> case readAddrOffAddr# a i s      of (# s2, x #) -> (# s2, Ptr x #)
 210 readFunPtrOffPtr (Ptr a) (I# i)
 211   = IO $ \s -> case readAddrOffAddr# a i s      of (# s2, x #) -> (# s2, FunPtr x #)
 212 readFloatOffPtr (Ptr a) (I# i)
 213   = IO $ \s -> case readFloatOffAddr# a i s     of (# s2, x #) -> (# s2, F# x #)
 214 readDoubleOffPtr (Ptr a) (I# i)
 215   = IO $ \s -> case readDoubleOffAddr# a i s    of (# s2, x #) -> (# s2, D# x #)
 216 readStablePtrOffPtr (Ptr a) (I# i)
 217   = IO $ \s -> case readStablePtrOffAddr# a i s of (# s2, x #) -> (# s2, StablePtr x #)
 218 readInt8OffPtr (Ptr a) (I# i)
 219   = IO $ \s -> case readInt8OffAddr# a i s      of (# s2, x #) -> (# s2, I8# x #)
 220 readInt16OffPtr (Ptr a) (I# i)
 221   = IO $ \s -> case readInt16OffAddr# a i s     of (# s2, x #) -> (# s2, I16# x #)
 222 readInt32OffPtr (Ptr a) (I# i)
 223   = IO $ \s -> case readInt32OffAddr# a i s     of (# s2, x #) -> (# s2, I32# x #)
 224 readInt64OffPtr (Ptr a) (I# i)
 225   = IO $ \s -> case readInt64OffAddr# a i s     of (# s2, x #) -> (# s2, I64# x #)
 226 readWord8OffPtr (Ptr a) (I# i)
 227   = IO $ \s -> case readWord8OffAddr# a i s     of (# s2, x #) -> (# s2, W8# x #)
 228 readWord16OffPtr (Ptr a) (I# i)
 229   = IO $ \s -> case readWord16OffAddr# a i s    of (# s2, x #) -> (# s2, W16# x #)
 230 readWord32OffPtr (Ptr a) (I# i)
 231   = IO $ \s -> case readWord32OffAddr# a i s    of (# s2, x #) -> (# s2, W32# x #)
 232 readWord64OffPtr (Ptr a) (I# i)
 233   = IO $ \s -> case readWord64OffAddr# a i s    of (# s2, x #) -> (# s2, W64# x #)
 234
 235 writeWideCharOffPtr  :: Ptr Char          -> Int -> Char        -> IO ()
 236 writeIntOffPtr       :: Ptr Int           -> Int -> Int         -> IO ()
 237 writeWordOffPtr      :: Ptr Word          -> Int -> Word        -> IO ()
 238 writePtrOffPtr       :: Ptr (Ptr a)       -> Int -> Ptr a       -> IO ()
 239 writeFunPtrOffPtr    :: Ptr (FunPtr a)    -> Int -> FunPtr a    -> IO ()
 240 writeFloatOffPtr     :: Ptr Float         -> Int -> Float       -> IO ()
 241 writeDoubleOffPtr    :: Ptr Double        -> Int -> Double      -> IO ()
 242 writeStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> StablePtr a -> IO ()
 243 writeInt8OffPtr      :: Ptr Int8          -> Int -> Int8        -> IO ()
 244 writeInt16OffPtr     :: Ptr Int16         -> Int -> Int16       -> IO ()
 245 writeInt32OffPtr     :: Ptr Int32         -> Int -> Int32       -> IO ()
 246 writeInt64OffPtr     :: Ptr Int64         -> Int -> Int64       -> IO ()
 247 writeWord8OffPtr     :: Ptr Word8         -> Int -> Word8       -> IO ()
 248 writeWord16OffPtr    :: Ptr Word16        -> Int -> Word16      -> IO ()
 249 writeWord32OffPtr    :: Ptr Word32        -> Int -> Word32      -> IO ()
 250 writeWord64OffPtr    :: Ptr Word64        -> Int -> Word64      -> IO ()
 251
 252 writeWideCharOffPtr (Ptr a) (I# i) (C# x)
 253   = IO $ \s -> case writeWideCharOffAddr# a i x s  of s2 -> (# s2, () #)
 254 writeIntOffPtr (Ptr a) (I# i) (I# x)
 255   = IO $ \s -> case writeIntOffAddr# a i x s       of s2 -> (# s2, () #)
 256 writeWordOffPtr (Ptr a) (I# i) (W# x)
 257   = IO $ \s -> case writeWordOffAddr# a i x s      of s2 -> (# s2, () #)
 258 writePtrOffPtr (Ptr a) (I# i) (Ptr x)
 259   = IO $ \s -> case writeAddrOffAddr# a i x s      of s2 -> (# s2, () #)
 260 writeFunPtrOffPtr (Ptr a) (I# i) (FunPtr x)
 261   = IO $ \s -> case writeAddrOffAddr# a i x s      of s2 -> (# s2, () #)
 262 writeFloatOffPtr (Ptr a) (I# i) (F# x)
 263   = IO $ \s -> case writeFloatOffAddr# a i x s     of s2 -> (# s2, () #)
 264 writeDoubleOffPtr (Ptr a) (I# i) (D# x)
 265   = IO $ \s -> case writeDoubleOffAddr# a i x s    of s2 -> (# s2, () #)
 266 writeStablePtrOffPtr (Ptr a) (I# i) (StablePtr x)
 267   = IO $ \s -> case writeStablePtrOffAddr# a i x s of s2 -> (# s2 , () #)
 268 writeInt8OffPtr (Ptr a) (I# i) (I8# x)
 269   = IO $ \s -> case writeInt8OffAddr# a i x s      of s2 -> (# s2, () #)
 270 writeInt16OffPtr (Ptr a) (I# i) (I16# x)
 271   = IO $ \s -> case writeInt16OffAddr# a i x s     of s2 -> (# s2, () #)
 272 writeInt32OffPtr (Ptr a) (I# i) (I32# x)
 273   = IO $ \s -> case writeInt32OffAddr# a i x s     of s2 -> (# s2, () #)
 274 writeInt64OffPtr (Ptr a) (I# i) (I64# x)
 275   = IO $ \s -> case writeInt64OffAddr# a i x s     of s2 -> (# s2, () #)
 276 writeWord8OffPtr (Ptr a) (I# i) (W8# x)
 277   = IO $ \s -> case writeWord8OffAddr# a i x s     of s2 -> (# s2, () #)
 278 writeWord16OffPtr (Ptr a) (I# i) (W16# x)
 279   = IO $ \s -> case writeWord16OffAddr# a i x s    of s2 -> (# s2, () #)
 280 writeWord32OffPtr (Ptr a) (I# i) (W32# x)
 281   = IO $ \s -> case writeWord32OffAddr# a i x s    of s2 -> (# s2, () #)
 282 writeWord64OffPtr (Ptr a) (I# i) (W64# x)
 283   = IO $ \s -> case writeWord64OffAddr# a i x s    of s2 -> (# s2, () #)
 284
 285 #endif /* __GLASGOW_HASKELL__ */
 286 \end{code}