lib/mlnlffi-lib/memory/memaccess.sml

   1 (* memaccess.sml
   2  * 2007 Matthew Fluet (mfluet@acm.org)
   3  *  Adapted for MLton.  Make use of $(SML_LIB)/basis/c-types.mlb
   4  * 2005 Matthew Fluet (mfluet@acm.org)
   5  *  Adapted for MLton.
   6  *)
   7
   8 (* memaccess-64-big.sml *)
   9 (* memaccess-64-little.sml *)
  10 (* memaccess-a4s2i4l4f4d8.sml
  11  *
  12  *   Primitives for "raw" memory access.
  13  *
  14  *   x86/Sparc/PPC version:
  15  *       addr char short  int  long float double
  16  *       4    1    2      4    4    4     8       (bytes)
  17  *
  18  *   (C) 2004 The Fellowship of SML/NJ
  19  *
  20  * author: Matthias Blume (blume@tti-c.org)
  21  *)
  22 structure CMemAccess : CMEMACCESS = struct
  23     structure Ptr = MLton.Pointer
  24
  25     type addr = Ptr.t
  26     val null = Ptr.null : addr
  27     fun isNull a = a = null
  28     infix ++ --
  29     (* rely on 2's-complement for the following... *)
  30     fun (a: addr) ++ i = Ptr.add (a, Word.fromInt i)
  31     val compare = Ptr.compare
  32     fun a1 -- a2 = Word.toIntX (Ptr.diff (a1, a2))
  33
  34     val addr_size = Word.fromInt (C_Size.wordSize div 8)
  35     val char_size = Word.fromInt (C_UChar.wordSize div 8)
  36     val short_size = Word.fromInt (C_UShort.wordSize div 8)
  37     val int_size = Word.fromInt (C_UInt.wordSize div 8)
  38     val long_size = Word.fromInt (C_ULong.wordSize div 8)
  39     val longlong_size = Word.fromInt (C_ULongLong.wordSize div 8)
  40     local
  41        structure RealNArg =
  42           struct
  43              type 'a t = int
  44              val fReal32 = 32
  45              val fReal64 = 64
  46           end
  47        structure Float = C_Float_ChooseRealN(RealNArg)
  48        structure Double = C_Double_ChooseRealN(RealNArg)
  49     in
  50        val float_size = Word.fromInt (Float.f div 8)
  51        val double_size = Word.fromInt (Double.f div 8)
  52     end
  53
  54     local
  55        fun get g addr =
  56           g (addr, 0)
  57        structure IntNArg =
  58           struct
  59              type 'a t = Ptr.t * int -> 'a
  60              val fInt8 = Ptr.getInt8
  61              val fInt16 = Ptr.getInt16
  62              val fInt32 = Ptr.getInt32
  63              val fInt64 = Ptr.getInt64
  64           end
  65        structure RealNArg =
  66           struct
  67              type 'a t = Ptr.t * int -> 'a
  68              val fReal32 = Ptr.getReal32
  69              val fReal64 = Ptr.getReal64
  70           end
  71        structure WordNArg =
  72           struct
  73              type 'a t = Ptr.t * int -> 'a
  74              val fWord8 = Ptr.getWord8
  75              val fWord16 = Ptr.getWord16
  76              val fWord32 = Ptr.getWord32
  77              val fWord64 = Ptr.getWord64
  78           end
  79        structure UChar = C_UChar_ChooseWordN(WordNArg)
  80        structure SChar = C_SChar_ChooseIntN(IntNArg)
  81        structure UShort = C_UShort_ChooseWordN(WordNArg)
  82        structure SShort = C_SShort_ChooseIntN(IntNArg)
  83        structure UInt = C_UInt_ChooseWordN(WordNArg)
  84        structure SInt = C_SInt_ChooseIntN(IntNArg)
  85        structure ULong = C_ULong_ChooseWordN(WordNArg)
  86        structure SLong = C_SLong_ChooseIntN(IntNArg)
  87        structure ULongLong = C_ULongLong_ChooseWordN(WordNArg)
  88        structure SLongLong = C_SLongLong_ChooseIntN(IntNArg)
  89        structure Float = C_Float_ChooseRealN(RealNArg)
  90        structure Double = C_Double_ChooseRealN(RealNArg)
  91     in
  92        val load_addr = get Ptr.getPointer
  93        val load_uchar = get UChar.f
  94        val load_schar = get SChar.f
  95        val load_ushort = get UShort.f
  96        val load_sshort = get SShort.f
  97        val load_uint = get UInt.f
  98        val load_sint = get SInt.f
  99        val load_ulong = get ULong.f
 100        val load_slong = get SLong.f
 101        val load_ulonglong = get ULongLong.f
 102        val load_slonglong = get SLongLong.f
 103        val load_float = get Float.f
 104        val load_double = get Double.f
 105     end
 106
 107     local
 108        fun set s (addr, x) =
 109           s (addr, 0, x)
 110        structure IntNArg =
 111           struct
 112              type 'a t = Ptr.t * int * 'a -> unit
 113              val fInt8 = Ptr.setInt8
 114              val fInt16 = Ptr.setInt16
 115              val fInt32 = Ptr.setInt32
 116              val fInt64 = Ptr.setInt64
 117           end
 118        structure RealNArg =
 119           struct
 120              type 'a t = Ptr.t * int * 'a -> unit
 121              val fReal32 = Ptr.setReal32
 122              val fReal64 = Ptr.setReal64
 123           end
 124        structure WordNArg =
 125           struct
 126              type 'a t = Ptr.t * int * 'a -> unit
 127              val fWord8 = Ptr.setWord8
 128              val fWord16 = Ptr.setWord16
 129              val fWord32 = Ptr.setWord32
 130              val fWord64 = Ptr.setWord64
 131           end
 132        structure UChar = C_UChar_ChooseWordN(WordNArg)
 133        structure SChar = C_SChar_ChooseIntN(IntNArg)
 134        structure UShort = C_UShort_ChooseWordN(WordNArg)
 135        structure SShort = C_SShort_ChooseIntN(IntNArg)
 136        structure UInt = C_UInt_ChooseWordN(WordNArg)
 137        structure SInt = C_SInt_ChooseIntN(IntNArg)
 138        structure ULong = C_ULong_ChooseWordN(WordNArg)
 139        structure SLong = C_SLong_ChooseIntN(IntNArg)
 140        structure ULongLong = C_ULongLong_ChooseWordN(WordNArg)
 141        structure SLongLong = C_SLongLong_ChooseIntN(IntNArg)
 142        structure Float = C_Float_ChooseRealN(RealNArg)
 143        structure Double = C_Double_ChooseRealN(RealNArg)
 144     in
 145        val store_addr = set Ptr.setPointer
 146        val store_uchar = set UChar.f
 147        val store_schar = set SChar.f
 148        val store_ushort = set UShort.f
 149        val store_sshort = set SShort.f
 150        val store_uint = set UInt.f
 151        val store_sint = set SInt.f
 152        val store_ulong = set ULong.f
 153        val store_slong = set SLong.f
 154        val store_ulonglong = set ULongLong.f
 155        val store_slonglong = set SLongLong.f
 156        val store_float = set Float.f
 157        val store_double = set Double.f
 158     end
 159
 160     val int_bits = int_size * 0w8
 161
 162     (* this needs to be severely optimized... *)
 163     fun bcopy { from: addr, to: addr, bytes: word } =
 164         if bytes > 0w0 then
 165             (store_uchar (to, load_uchar from);
 166              bcopy { from = from ++ 1, to = to ++ 1, bytes = bytes - 0w1 })
 167         else ()
 168
 169     (* types used in C calling convention *)
 170     type cc_addr = MLton.Pointer.t
 171     type cc_schar = C_SChar.int
 172     type cc_uchar = C_UChar.word
 173     type cc_sshort = C_SShort.int
 174     type cc_ushort = C_UShort.word
 175     type cc_sint = C_SInt.int
 176     type cc_uint = C_UInt.word
 177     type cc_slong = C_SLong.int
 178     type cc_ulong = C_ULong.word
 179     type cc_slonglong = C_SLongLong.int
 180     type cc_ulonglong = C_ULongLong.word
 181     type cc_float = C_Float.real
 182     type cc_double = C_Double.real
 183
 184     (* wrapping and unwrapping for cc types *)
 185     fun wrap_addr (x : addr) = x : cc_addr
 186     fun wrap_schar (x : MLRep.Char.Signed.int) = x : cc_schar
 187     fun wrap_uchar (x : MLRep.Char.Unsigned.word) = x : cc_uchar
 188     fun wrap_sshort (x : MLRep.Short.Signed.int) = x : cc_sshort
 189     fun wrap_ushort (x : MLRep.Short.Unsigned.word) = x : cc_ushort
 190     fun wrap_sint (x : MLRep.Int.Signed.int) = x : cc_sint
 191     fun wrap_uint (x : MLRep.Int.Unsigned.word) = x : cc_uint
 192     fun wrap_slong (x : MLRep.Long.Signed.int) = x : cc_slong
 193     fun wrap_ulong (x : MLRep.Long.Unsigned.word) = x : cc_ulong
 194     fun wrap_slonglong (x : MLRep.LongLong.Signed.int) = x : cc_slonglong
 195     fun wrap_ulonglong (x : MLRep.LongLong.Unsigned.word) = x : cc_ulonglong
 196     fun wrap_float (x : MLRep.Float.real) = x : cc_float
 197     fun wrap_double (x : MLRep.Double.real) = x : cc_double
 198
 199     fun unwrap_addr (x : cc_addr) = x : addr
 200     fun unwrap_schar (x : cc_schar) = x : MLRep.Char.Signed.int
 201     fun unwrap_uchar (x : cc_uchar) = x : MLRep.Char.Unsigned.word
 202     fun unwrap_sshort (x : cc_sshort) = x : MLRep.Short.Signed.int
 203     fun unwrap_ushort (x : cc_ushort) = x : MLRep.Short.Unsigned.word
 204     fun unwrap_sint (x : cc_sint) = x : MLRep.Int.Signed.int
 205     fun unwrap_uint (x : cc_uint) = x : MLRep.Int.Unsigned.word
 206     fun unwrap_slong (x : cc_slong) = x : MLRep.Long.Signed.int
 207     fun unwrap_ulong (x : cc_ulong) = x : MLRep.Long.Unsigned.word
 208     fun unwrap_slonglong (x : cc_slonglong) = x : MLRep.LongLong.Signed.int
 209     fun unwrap_ulonglong (x : cc_ulonglong) = x : MLRep.LongLong.Unsigned.word
 210     fun unwrap_float (x : cc_float) = x : MLRep.Float.real
 211     fun unwrap_double (x : cc_double) = x : MLRep.Double.real
 212
 213     fun p2i (x : addr) : MLRep.Long.Unsigned.word =
 214        C_ULong.fromLarge (Word.toLarge (Ptr.diff (x, null)))
 215     fun i2p (x : MLRep.Long.Unsigned.word) : addr =
 216        Ptr.add (null, Word.fromLarge (C_ULong.toLarge x))
 217 end