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

Parent Directory | Revision Log

---

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

---

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