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 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