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/internals/c-int.sml
ViewVC logotype

Annotation of /sml/trunk/src/ml-nlffi-lib/internals/c-int.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1015 - (view) (download)

1 : blume 828 (*
2 :     * The implementation of the interface that encodes C's type system
3 :     * in ML. This implementation includes its "private" extensions.
4 :     *
5 :     * (C) 2001, Lucent Technologies, Bell Laboratories
6 :     *
7 : blume 975 * author: Matthias Blume (blume@research.bell-labs.com)
8 : blume 828 *)
9 :     local
10 :     (* We play some games here with first calling C_Int simply C and then
11 :     * renaming it because they result in saner printing behavior. *)
12 :     structure C :> C_INT = struct
13 :    
14 : blume 1015 exception OutOfMemory = CMemory.OutOfMemory
15 :    
16 : blume 828 fun bug m = raise Fail ("impossible: " ^ m)
17 :    
18 :     type addr = CMemory.addr
19 :    
20 :     local
21 : blume 837 datatype objt =
22 : blume 828 BASE of word
23 : blume 837 | PTR of objt
24 :     | FPTR of Unsafe.Object.object (* == addr -> 'f *)
25 :     | ARR of { typ: objt, n: word, esz: int, asz: word }
26 : blume 828
27 :     (* Bitfield: b bits wide, l bits from left corner, r bits from right.
28 :     * The word itself is CMemory.int_bits wide and located at address a.
29 :     *
30 :     * MSB LSB
31 :     * V |<---b--->| V
32 :     * |<---l---> ......... <---r--->|
33 :     * |<----------wordsize--------->|
34 :     *
35 :     * 0.......0 1.......1 0.......0 = m
36 :     * 1.......1 0.......0 1.......1 = im
37 :     *
38 :     * l + r = lr *)
39 :     type cword = MLRep.UInt.word
40 :     type bf = { a: addr, l: word, r: word, lr: word, m: cword, im: cword }
41 :    
42 : blume 837 fun pair_type_addr (t: objt) (a: addr) = (a, t)
43 :     fun strip_type (a: addr, _: objt) = a
44 :     fun p_strip_type (a: addr, _: objt) = a
45 : blume 828 fun strip_fun (a: addr, _: 'f) = a
46 : blume 837 fun addr_type_id (x: addr * objt) = x
47 : blume 828 fun addr_id (x: addr) = x
48 :    
49 :     infix -- ++
50 :     val op -- = CMemory.--
51 :     val op ++ = CMemory.++
52 :    
53 :     infix << >> ~>> && || ^^
54 :     val op << = MLRep.UInt.<<
55 :     val op >> = MLRep.UInt.>>
56 :     val op ~>> = MLRep.UInt.~>>
57 :     val op && = MLRep.UInt.andb
58 :     val op || = MLRep.UInt.orb
59 :     val op ^^ = MLRep.UInt.xorb
60 :     val ~~ = MLRep.UInt.notb
61 :     in
62 :    
63 : blume 975 type ('t, 'c) obj = addr * objt (* RTTI for stored value *)
64 : blume 837 type ('t, 'c) obj' = addr
65 : blume 828
66 :     type ro = unit
67 :     type rw = unit
68 :    
69 : blume 975 type ('t, 'c) ptr = addr * objt (* RTTI for target value *)
70 : blume 837 type ('t, 'c) ptr' = addr
71 : blume 828
72 : blume 836 type ('t, 'n) arr = unit
73 : blume 828
74 :     type 'f fptr = addr * 'f
75 :     type 'f fptr' = addr (* does not carry function around *)
76 :    
77 :     type voidptr = addr
78 :     type 'tag su = unit
79 :    
80 :     type schar = MLRep.SChar.int
81 :     type uchar = MLRep.UChar.word
82 :     type sint = MLRep.SInt.int
83 :     type uint = MLRep.UInt.word
84 :     type sshort = MLRep.SShort.int
85 :     type ushort = MLRep.UShort.word
86 :     type slong = MLRep.SLong.int
87 :     type ulong = MLRep.ULong.word
88 :     type float = MLRep.Float.real
89 :     type double = MLRep.Double.real
90 :    
91 : blume 837 type 'c schar_obj = (schar, 'c) obj
92 :     type 'c uchar_obj = (uchar, 'c) obj
93 :     type 'c sint_obj = (sint, 'c) obj
94 :     type 'c uint_obj = (uint, 'c) obj
95 :     type 'c sshort_obj = (sshort, 'c) obj
96 :     type 'c ushort_obj = (ushort, 'c) obj
97 :     type 'c slong_obj = (slong, 'c) obj
98 :     type 'c ulong_obj = (ulong, 'c) obj
99 :     type 'c float_obj = (float, 'c) obj
100 :     type 'c double_obj = (double, 'c) obj
101 :     type 'c voidptr_obj = (voidptr, 'c) obj
102 :     type ('f, 'c) fptr_obj = ('f fptr, 'c) obj
103 :     type ('s, 'c) su_obj = ('s su, 'c) obj
104 : blume 828
105 : blume 837 type 'c schar_obj' = (schar, 'c) obj'
106 :     type 'c uchar_obj' = (uchar, 'c) obj'
107 :     type 'c sint_obj' = (sint, 'c) obj'
108 :     type 'c uint_obj' = (uint, 'c) obj'
109 :     type 'c sshort_obj' = (sshort, 'c) obj'
110 :     type 'c ushort_obj' = (ushort, 'c) obj'
111 :     type 'c slong_obj' = (slong, 'c) obj'
112 :     type 'c ulong_obj' = (ulong, 'c) obj'
113 :     type 'c float_obj' = (float, 'c) obj'
114 :     type 'c double_obj' = (double, 'c) obj'
115 :     type 'c voidptr_obj' = (voidptr, 'c) obj'
116 :     type ('f, 'c) fptr_obj' = ('f fptr, 'c) obj'
117 :     type ('s, 'c) su_obj' = ('s su, 'c) obj'
118 : blume 828
119 :     type 'c ubf = bf
120 :     type 'c sbf = bf
121 :    
122 :     (*
123 :     * A family of types and corresponding values representing natural numbers.
124 :     * (An encoding in SML without using dependent types.)
125 :     * This is the full implementation including an unsafe extension
126 :     * ("fromInt"). *)
127 :    
128 :     structure Dim = struct
129 :    
130 :     type ('a, 'z) dim0 = int
131 :     fun toInt d = d
132 :     fun fromInt d = d
133 :    
134 :     type dec = unit
135 :     type 'a dg0 = unit
136 :     type 'a dg1 = unit
137 :     type 'a dg2 = unit
138 :     type 'a dg3 = unit
139 :     type 'a dg4 = unit
140 :     type 'a dg5 = unit
141 :     type 'a dg6 = unit
142 :     type 'a dg7 = unit
143 :     type 'a dg8 = unit
144 :     type 'a dg9 = unit
145 :    
146 :     type zero = unit
147 :     type nonzero = unit
148 :    
149 :     type 'a dim = ('a, nonzero) dim0
150 :    
151 :     local
152 :     fun dg n d = 10 * d + n
153 :     in
154 :     val dec' = 0
155 : blume 840 val (dg0', dg1', dg2', dg3', dg4', dg5', dg6', dg7', dg8', dg9') =
156 :     (dg 0, dg 1, dg 2, dg 3, dg 4, dg 5, dg 6, dg 7, dg 8, dg 9)
157 : blume 828
158 :     fun dec k = k dec'
159 :     fun dg0 d k = k (dg0' d)
160 :     fun dg1 d k = k (dg1' d)
161 :     fun dg2 d k = k (dg2' d)
162 :     fun dg3 d k = k (dg3' d)
163 :     fun dg4 d k = k (dg4' d)
164 :     fun dg5 d k = k (dg5' d)
165 :     fun dg6 d k = k (dg6' d)
166 :     fun dg7 d k = k (dg7' d)
167 :     fun dg8 d k = k (dg8' d)
168 :     fun dg9 d k = k (dg9' d)
169 :     fun dim d = d
170 :     end
171 :     end
172 :    
173 :     structure S = struct
174 :    
175 :     type 't size = word
176 :    
177 :     fun toWord (s: 't size) = s
178 :    
179 :     val schar = CMemory.char_size
180 :     val uchar = CMemory.char_size
181 :     val sint = CMemory.int_size
182 :     val uint = CMemory.int_size
183 :     val sshort = CMemory.short_size
184 :     val ushort = CMemory.short_size
185 :     val slong = CMemory.long_size
186 :     val ulong = CMemory.long_size
187 :     val float = CMemory.float_size
188 :     val double = CMemory.double_size
189 :    
190 :     val voidptr = CMemory.addr_size
191 :     val ptr = CMemory.addr_size
192 :     val fptr = CMemory.addr_size
193 :     end
194 :    
195 :     structure T = struct
196 :    
197 : blume 837 type 't typ = objt
198 : blume 828
199 : blume 837 fun typeof (_: addr, t: objt) = t
200 : blume 828
201 :     fun sizeof (BASE b) = b
202 :     | sizeof (PTR _) = S.ptr
203 :     | sizeof (FPTR _) = S.fptr
204 :     | sizeof (ARR a) = #asz a
205 :    
206 :     (* use private (and unsafe) extension to Dim module here... *)
207 :     fun dim (ARR { n, ... }) = Dim.fromInt (Word.toInt n)
208 :     | dim _ = bug "T.dim (non-array type)"
209 :    
210 :     fun pointer t = PTR t
211 :     fun target (PTR t) = t
212 :     | target _ = bug "T.target (non-pointer type)"
213 :     fun arr (t, d) = let
214 :     val n = Word.fromInt (Dim.toInt d)
215 :     val s = sizeof t
216 :     in
217 :     ARR { typ = t, n = n, esz = Word.toInt s, asz = n * s }
218 :     end
219 :     fun elem (ARR a) = #typ a
220 :     | elem _ = bug "T.elem (non-array type)"
221 : blume 837 fun ro (t: objt) = t
222 : blume 828
223 :     val schar = BASE S.schar
224 :     val uchar = BASE S.uchar
225 :     val sint = BASE S.sint
226 :     val uint = BASE S.uint
227 :     val sshort = BASE S.sshort
228 :     val ushort = BASE S.ushort
229 :     val slong = BASE S.slong
230 :     val ulong = BASE S.ulong
231 :     val float = BASE S.float
232 :     val double = BASE S.double
233 :    
234 :     val voidptr = BASE S.voidptr
235 :     end
236 :    
237 :     structure Light = struct
238 :     val obj = p_strip_type
239 :     val ptr = p_strip_type
240 :     val fptr = strip_fun
241 :     end
242 :    
243 :     structure Heavy = struct
244 :     val obj = pair_type_addr
245 :     val ptr = pair_type_addr
246 :    
247 : blume 837 fun fptr (FPTR mkf) p = (p, Unsafe.cast mkf p)
248 : blume 828 | fptr _ _ = bug "Heavy.fptr (non-function-pointer-type)"
249 :     end
250 :    
251 :     fun sizeof (_: addr, t) = T.sizeof t
252 :    
253 :     structure Cvt = struct
254 :     (* going between abstract and concrete; these are all identities *)
255 :     fun c_schar (c: schar) = c
256 :     fun c_uchar (c: uchar) = c
257 :     fun c_sint (i: sint) = i
258 :     fun c_uint (i: uint) = i
259 :     fun c_sshort (s: sshort) = s
260 :     fun c_ushort (s: ushort) = s
261 :     fun c_slong (l: slong) = l
262 :     fun c_ulong (l: ulong) = l
263 :     fun c_float (f: float) = f
264 :     fun c_double (d: double) = d
265 :    
266 :     val ml_schar = c_schar
267 :     val ml_uchar = c_uchar
268 :     val ml_sint = c_sint
269 :     val ml_uint = c_uint
270 :     val ml_sshort = c_sshort
271 :     val ml_ushort = c_ushort
272 :     val ml_slong = c_slong
273 :     val ml_ulong = c_ulong
274 :     val ml_float = c_float
275 :     val ml_double = c_double
276 :     end
277 :    
278 :     structure Get = struct
279 :     val uchar' = CMemory.load_uchar
280 :     val schar' = CMemory.load_schar
281 :     val uint' = CMemory.load_uint
282 :     val sint' = CMemory.load_sint
283 :     val ushort' = CMemory.load_ushort
284 :     val sshort' = CMemory.load_sshort
285 :     val ulong' = CMemory.load_ulong
286 :     val slong' = CMemory.load_slong
287 :     val float' = CMemory.load_float
288 :     val double' = CMemory.load_double
289 :    
290 :     val ptr' = CMemory.load_addr
291 :     val fptr' = CMemory.load_addr
292 :     val voidptr' = CMemory.load_addr
293 :    
294 :     val uchar = uchar' o strip_type
295 :     val schar = schar' o strip_type
296 :     val uint = uint' o strip_type
297 :     val sint = sint' o strip_type
298 :     val ushort = ushort' o strip_type
299 :     val sshort = sshort' o strip_type
300 :     val ulong = ulong' o strip_type
301 :     val slong = slong' o strip_type
302 :     val float = float' o strip_type
303 :     val double = double' o strip_type
304 :     val voidptr = voidptr' o strip_type
305 :    
306 :     fun ptr (a, PTR t) = (CMemory.load_addr a, t)
307 :     | ptr _ = bug "Get.ptr (non-pointer)"
308 :     fun fptr (a, FPTR mkf) =
309 : blume 837 let val fa = CMemory.load_addr a in (fa, Unsafe.cast mkf fa) end
310 : blume 828 | fptr _ = bug "Get.fptr (non-function-pointer)"
311 :    
312 :     local
313 :     val u2s = MLRep.SInt.fromLarge o MLRep.UInt.toLargeIntX
314 :     in
315 :     fun ubf ({ a, l, r, lr, m, im } : bf) =
316 :     (CMemory.load_uint a << l) >> lr
317 :     fun sbf ({ a, l, r, lr, m, im } : bf) =
318 :     u2s ((CMemory.load_uint a << l) ~>> lr)
319 :     end
320 :     end
321 :    
322 :     structure Set = struct
323 :     val uchar' = CMemory.store_uchar
324 :     val schar' = CMemory.store_schar
325 :     val uint' = CMemory.store_uint
326 :     val sint' = CMemory.store_sint
327 :     val ushort' = CMemory.store_ushort
328 :     val sshort' = CMemory.store_sshort
329 :     val ulong' = CMemory.store_ulong
330 :     val slong' = CMemory.store_slong
331 :     val float' = CMemory.store_float
332 :     val double' = CMemory.store_double
333 :    
334 :     val ptr' = CMemory.store_addr
335 :     val fptr' = CMemory.store_addr
336 :     val voidptr' = CMemory.store_addr
337 :     val ptr_voidptr' = CMemory.store_addr
338 :    
339 :     local
340 :     infix $
341 :     fun (f $ g) (x, y) = f (g x, y)
342 :     in
343 :     val uchar = uchar' $ strip_type
344 :     val schar = schar' $ strip_type
345 :     val uint = uint' $ strip_type
346 :     val sint = sint' $ strip_type
347 :     val ushort = ushort' $ strip_type
348 :     val sshort = sshort' $ strip_type
349 :     val ulong = ulong' $ strip_type
350 :     val slong = slong' $ strip_type
351 :     val float = float' $ strip_type
352 :     val double = double' $ strip_type
353 :     val voidptr = voidptr' $ strip_type
354 :    
355 :     fun ptr_voidptr (x, p) = ptr_voidptr' (p_strip_type x, p)
356 :    
357 :     fun ptr (x, p) = ptr' (p_strip_type x, p_strip_type p)
358 :     fun fptr (x, f) = fptr' (p_strip_type x, strip_fun f)
359 :     end
360 :    
361 :     fun ubf ({ a, l, r, lr, m, im }, x) =
362 :     CMemory.store_uint (a, (CMemory.load_uint a && im) ||
363 :     ((x << r) && m))
364 :    
365 :     local
366 :     val s2u = MLRep.UInt.fromLargeInt o MLRep.SInt.toLarge
367 :     in
368 :     fun sbf (f, x) = ubf (f, s2u x)
369 :     end
370 :     end
371 :    
372 :     fun copy' bytes { from, to } =
373 :     CMemory.bcopy { from = from, to = to, bytes = bytes }
374 : blume 837 fun copy { from = (from, t), to = (to, _: objt) } =
375 : blume 828 copy' (T.sizeof t) { from = from, to = to }
376 :    
377 :     structure Ptr = struct
378 :     val |&| = addr_type_id
379 :     val |*| = addr_type_id
380 :    
381 :     val |&! = addr_id
382 :     val |*! = addr_id
383 :    
384 :     fun compare (p, p') = CMemory.compare (p_strip_type p, p_strip_type p')
385 :    
386 :     val compare' = CMemory.compare
387 :    
388 :     val inject' = addr_id
389 : blume 837 fun cast' (_ : objt) = addr_id
390 : blume 828
391 :     val inject = p_strip_type
392 : blume 837 fun cast (PTR t) (p : voidptr) = (p, t)
393 :     | cast _ _ = bug "Ptr.cast (non-pointer-type)"
394 : blume 828
395 :     val vNull = CMemory.null
396 : blume 837 fun null t = cast t vNull
397 : blume 828 val null' = CMemory.null
398 :    
399 :     val vIsNull = CMemory.isNull
400 :     fun isNull p = vIsNull (inject p)
401 :     val isNull' = CMemory.isNull
402 :    
403 :     fun |+! s (p, i) = p ++ (Word.toInt s * i)
404 :     fun |-! s (p, p') = (p -- p') div Word.toInt s
405 :    
406 :     fun |+| ((p, t), i) = (|+! (T.sizeof t) (p, i), t)
407 : blume 837 fun |-| ((p, t), (p', _: objt)) = |-! (T.sizeof t) (p, p')
408 : blume 828
409 :     fun sub (p, i) = |*| (|+| (p, i))
410 :    
411 :     fun sub' t (p, i) = |*! (|+! t (p, i))
412 :     end
413 :    
414 :     val ro = addr_type_id
415 :     val rw = addr_type_id
416 :    
417 :     val ro' = addr_id
418 :     val rw' = addr_id
419 :    
420 :     structure Arr = struct
421 :     local
422 :     fun asub (a, i, ARR { typ, n, esz, ... }) =
423 :     (* take advantage of wrap-around to avoid the >= 0 test... *)
424 :     if Word.fromInt i < n then (a ++ (esz * i), typ)
425 :     else raise General.Subscript
426 :     | asub _ = bug "Arr.sub(') (non-array)"
427 :     in
428 :     fun sub ((a, t), i) = asub (a, i, t)
429 :     fun sub' t (a, i) = #1 (asub (a, i, t))
430 :     end
431 :    
432 :     fun decay (a, ARR { typ, ... }) = (a, typ)
433 :     | decay _ = bug "Arr.decay (non-array)"
434 :    
435 :     val decay' = addr_id
436 :    
437 :     fun reconstruct ((a: addr, t), d) = (a, T.arr (t, d))
438 :    
439 :     fun reconstruct' (a: addr, d: 'n Dim.dim) = a
440 :    
441 :     fun dim (_: addr, t) = T.dim t
442 :     end
443 :    
444 : blume 837 fun new' s = CMemory.alloc s
445 : blume 1015 fun new t = (new' (T.sizeof t), t)
446 : blume 828
447 :     val discard' = CMemory.free
448 :     fun discard x = discard' (p_strip_type x)
449 :    
450 : blume 837 fun alloc' s i = CMemory.alloc (s * i)
451 : blume 1015 fun alloc t i = (alloc' (T.sizeof t) i, t)
452 : blume 828
453 :     val free' = CMemory.free
454 :     fun free x = free' (p_strip_type x)
455 :    
456 :     fun call ((_: addr, f), x) = f x
457 :    
458 : blume 837 fun call' (FPTR mkf) (a, x) = Unsafe.cast mkf a x
459 : blume 828 | call' _ _ = bug "call' (non-function-pointer-type)"
460 :    
461 : blume 1015 structure U = struct
462 :     fun fcast (f : 'a fptr') : 'b fptr' = f
463 :     fun p2i (a : voidptr) : ulong = CMemory.p2i a
464 :     fun i2p (a : ulong) : voidptr = CMemory.i2p a
465 :     end
466 :    
467 : blume 828 (* ------------- internal stuff ------------- *)
468 :    
469 : blume 1011 fun mk_obj (t: objt, a: addr) = (a, t)
470 : blume 828 fun mk_voidptr (a : addr) = a
471 : blume 1011 fun mk_fptr (mkf, a) = (a, mkf a)
472 : blume 828
473 :     local
474 : blume 1011 fun mk_field (t: objt, i, (a, _: objt)) = (a ++ i, t)
475 : blume 828 in
476 :     val mk_rw_field = mk_field
477 :     val mk_ro_field = mk_field
478 : blume 1011 fun mk_field' (i, a) = a ++ i
479 : blume 828 end
480 :    
481 :     local
482 :     fun mk_bf' (offset, bits, shift) a = let
483 :     val a = a ++ offset
484 :     val l = shift
485 :     val lr = CMemory.int_bits - bits
486 :     val r = lr - l
487 :     val m = (~~0w0 << lr) >> l
488 :     val im = ~~ m
489 :     in
490 :     { a = a, l = l, r = r, lr = lr, m = m, im = im } : bf
491 :     end
492 : blume 837 fun mk_bf acc (a, _: objt) = mk_bf' acc a
493 : blume 828 in
494 :     val mk_rw_ubf = mk_bf
495 :     val mk_ro_ubf = mk_bf
496 :     val mk_rw_ubf' = mk_bf'
497 :     val mk_ro_ubf' = mk_bf'
498 :    
499 :     val mk_rw_sbf = mk_bf
500 :     val mk_ro_sbf = mk_bf
501 :     val mk_rw_sbf' = mk_bf'
502 :     val mk_ro_sbf' = mk_bf'
503 :     end
504 :    
505 :     fun mk_su_size sz = sz
506 :     fun mk_su_typ sz = BASE sz
507 : blume 837 fun mk_fptr_typ (mkf: addr -> 'a -> 'b) = FPTR (Unsafe.cast mkf)
508 : blume 828
509 :     val reveal = addr_id
510 :     val freveal = addr_id
511 :    
512 :     val vcast = addr_id
513 :     val pcast = addr_id
514 :     val fcast = addr_id
515 :    
516 :     fun unsafe_sub esz (a, i) = a ++ esz * i
517 :    
518 :     end (* local *)
519 :     end
520 :     in
521 :     structure C_Int = C
522 :     end

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