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-x86.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 828 - (view) (download)

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

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