ghc/lib/std/PrelStorable.lhs

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