Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/ml-nlffi-lib/memory/memory-a4s2i4l4f4d8.sml
ViewVC logotype

Annotation of /sml/trunk/src/ml-nlffi-lib/memory/memory-a4s2i4l4f4d8.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1015 - (view) (download)

1 : blume 840 (*
2 :     * Primitives for "raw" memory access.
3 :     *
4 :     * x86/Sparc version:
5 :     * addr char short int long float double
6 :     * 4 1 2 4 4 4 8 (bytes)
7 :     *
8 :     * (C) 2001, Lucent Technologies, Bell Laboratories
9 :     *
10 : blume 975 * author: Matthias Blume (blume@research.bell-labs.com)
11 : blume 840 *)
12 :     structure CMemory : CMEMORY = struct
13 : blume 1015 exception OutOfMemory
14 :    
15 : blume 840 type addr = Word32.word
16 :     val null = 0w0 : addr
17 :     fun isNull a = a = null
18 :     infix ++ --
19 :     (* rely on 2's-complement for the following... *)
20 :     fun (a: addr) ++ i = a + Word32.fromInt i
21 :     val compare = Word32.compare
22 :     fun a1 -- a2 = Word32.toIntX (a1 - a2)
23 :    
24 :     val addr_size = 0w4
25 :     val char_size = 0w1
26 :     val short_size = 0w2
27 :     val int_size = 0w4
28 :     val long_size = 0w4
29 :     val float_size = 0w4
30 :     val double_size = 0w8
31 :    
32 :     val load_addr = RawMemInlineT.w32l
33 :     val load_uchar = RawMemInlineT.w8l
34 :     val load_schar = RawMemInlineT.i8l
35 :     val load_ushort = RawMemInlineT.w16l
36 :     val load_sshort = RawMemInlineT.i16l
37 :     val load_uint = RawMemInlineT.w32l
38 :     val load_sint = RawMemInlineT.i32l
39 :     val load_ulong = RawMemInlineT.w32l
40 :     val load_slong = RawMemInlineT.i32l
41 :     val load_float = RawMemInlineT.f32l
42 :     val load_double = RawMemInlineT.f64l
43 :    
44 :     val store_addr = RawMemInlineT.w32s
45 :     val store_uchar = RawMemInlineT.w8s
46 :     val store_schar = RawMemInlineT.i8s
47 :     val store_ushort = RawMemInlineT.w16s
48 :     val store_sshort = RawMemInlineT.i16s
49 :     val store_uint = RawMemInlineT.w32s
50 :     val store_sint = RawMemInlineT.i32s
51 :     val store_ulong = RawMemInlineT.w32s
52 :     val store_slong = RawMemInlineT.i32s
53 :     val store_float = RawMemInlineT.f32s
54 :     val store_double = RawMemInlineT.f64s
55 :    
56 :     val int_bits = Word.fromInt Word32.wordSize
57 :    
58 :     (* this needs to be severely optimized... *)
59 :     fun bcopy { from: addr, to: addr, bytes: word } =
60 :     if bytes > 0w0 then
61 :     (store_uchar (to, load_uchar from);
62 :     bcopy { from = from + 0w1, to = to + 0w1, bytes = bytes - 0w1 })
63 :     else ()
64 :    
65 :     local
66 :     structure DL = DynLinkage
67 : blume 1011 fun main's s = DL.lib_symbol (DL.main_lib, s)
68 : blume 840 val malloc_h = main's "malloc"
69 :     val free_h = main's "free"
70 :     fun sys_malloc (n : Word32.word) = let
71 :     val w_p = RawMemInlineT.rawccall :
72 :     Word32.word * Word32.word * (unit * word -> string) list
73 :     -> Word32.word
74 :     val a = w_p (DL.addr malloc_h, n, [])
75 :     in
76 : blume 1015 if a = 0w0 then raise OutOfMemory else a
77 : blume 840 end
78 :     fun sys_free (a : Word32.word) = let
79 :     val p_u = RawMemInlineT.rawccall :
80 :     Word32.word * Word32.word * (unit * string -> unit) list
81 :     -> unit
82 :     in
83 :     p_u (DL.addr free_h, a, [])
84 :     end
85 :     in
86 :     fun alloc bytes = sys_malloc (Word.toLargeWord bytes)
87 :     fun free a = sys_free a
88 :     end
89 :    
90 :     (* types used in C calling convention *)
91 :     type cc_addr = Word32.word
92 :     type cc_schar = Int32.int
93 :     type cc_uchar = Word32.word
94 :     type cc_sint = Int32.int
95 :     type cc_uint = Word32.word
96 :     type cc_sshort = Int32.int
97 :     type cc_ushort = Word32.word
98 :     type cc_slong = Int32.int
99 :     type cc_ulong = Word32.word
100 :     type cc_float = Real.real
101 :     type cc_double = Real.real
102 :    
103 :     (* wrapping and unwrapping for cc types *)
104 :     fun wrap_addr (x : addr) = x : cc_addr
105 :     fun wrap_schar (x : MLRep.SChar.int) = x : cc_schar
106 :     fun wrap_uchar (x : MLRep.UChar.word) = x : cc_uchar
107 :     fun wrap_sint (x : MLRep.SInt.int) = x : cc_sint
108 :     fun wrap_uint (x : MLRep.UInt.word) = x : cc_uint
109 :     fun wrap_sshort (x : MLRep.SShort.int) = x : cc_sshort
110 :     fun wrap_ushort (x : MLRep.UShort.word) = x : cc_ushort
111 :     fun wrap_slong (x : MLRep.SLong.int) = x : cc_slong
112 :     fun wrap_ulong (x : MLRep.ULong.word) = x : cc_ulong
113 :     fun wrap_float (x : MLRep.Float.real) = x : cc_float
114 :     fun wrap_double (x : MLRep.Double.real) = x : cc_double
115 :    
116 :     fun unwrap_addr (x : cc_addr) = x : addr
117 :     fun unwrap_schar (x : cc_schar) = x : MLRep.SChar.int
118 :     fun unwrap_uchar (x : cc_uchar) = x : MLRep.UChar.word
119 :     fun unwrap_sint (x : cc_sint) = x : MLRep.SInt.int
120 :     fun unwrap_uint (x : cc_uint) = x : MLRep.UInt.word
121 :     fun unwrap_sshort (x : cc_sshort) = x : MLRep.SShort.int
122 :     fun unwrap_ushort (x : cc_ushort) = x : MLRep.UShort.word
123 :     fun unwrap_slong (x : cc_slong) = x : MLRep.SLong.int
124 :     fun unwrap_ulong (x : cc_ulong) = x : MLRep.ULong.word
125 :     fun unwrap_float (x : cc_float) = x : MLRep.Float.real
126 :     fun unwrap_double (x : cc_double) = x : MLRep.Double.real
127 : blume 1015
128 :     fun p2i (x : addr) = x : MLRep.ULong.word
129 :     fun i2p (x : MLRep.ULong.word) = x : addr
130 : blume 840 end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0