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

SCM Repository

[smlnj] Diff of /sml/trunk/src/ml-nlffi-lib/internals/c-int.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 836, Fri May 25 19:28:51 2001 UTC revision 837, Fri Jun 1 17:27:54 2001 UTC
# Line 16  Line 16 
16      type addr = CMemory.addr      type addr = CMemory.addr
17    
18      local      local
19          datatype 'f objt =          datatype objt =
20              BASE of word              BASE of word
21            | PTR of 'f objt            | PTR of objt
22            | FPTR of addr -> 'f            | FPTR of Unsafe.Object.object (* == addr -> 'f *)
23            | ARR of { typ: 'f objt, n: word, esz: int, asz: word }            | ARR of { typ: objt, n: word, esz: int, asz: word }
24    
25          (* Bitfield: b bits wide, l bits from left corner, r bits from right.          (* 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.           * The word itself is CMemory.int_bits wide and located at address a.
# Line 37  Line 37 
37          type cword = MLRep.UInt.word          type cword = MLRep.UInt.word
38          type bf = { a: addr, l: word, r: word, lr: word, m: cword, im: cword }          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)          fun pair_type_addr (t: objt) (a: addr) = (a, t)
41          fun strip_type (a: addr, _: unit objt) = a          fun strip_type (a: addr, _: objt) = a
42          fun p_strip_type (a: addr, _: 'f objt) = a          fun p_strip_type (a: addr, _: objt) = a
43          fun strip_fun (a: addr, _: 'f) = a          fun strip_fun (a: addr, _: 'f) = a
44          fun addr_type_id (x: addr * 'f objt) = x          fun addr_type_id (x: addr * objt) = x
45          fun addr_id (x: addr) = x          fun addr_id (x: addr) = x
46    
47          infix -- ++          infix -- ++
# Line 58  Line 58 
58          val ~~ = MLRep.UInt.notb          val ~~ = MLRep.UInt.notb
59      in      in
60    
61      type ('t, 'f, 'c) obj = addr * 'f objt (* RTI for stored value *)      type ('t, 'c) obj = addr * objt     (* RTI for stored value *)
62      type ('t, 'f, 'c) obj' = addr      type ('t, 'c) obj' = addr
63    
64      type ro = unit      type ro = unit
65      type rw = unit      type rw = unit
66    
67      type ('t, 'f, 'c) ptr = addr * 'f objt (* RTI for target value *)      type ('t, 'c) ptr = addr * objt     (* RTI for target value *)
68      type ('t, 'f, 'c) ptr' = addr      type ('t, 'c) ptr' = addr
69    
70      type ('t, 'n) arr = unit      type ('t, 'n) arr = unit
71    
# Line 86  Line 86 
86      type float = MLRep.Float.real      type float = MLRep.Float.real
87      type double = MLRep.Double.real      type double = MLRep.Double.real
88    
89      type 'c schar_obj = (schar, unit, 'c) obj      type 'c schar_obj = (schar, 'c) obj
90      type 'c uchar_obj = (uchar, unit, 'c) obj      type 'c uchar_obj = (uchar, 'c) obj
91      type 'c sint_obj = (sint, unit, 'c) obj      type 'c sint_obj = (sint, 'c) obj
92      type 'c uint_obj = (uint, unit, 'c) obj      type 'c uint_obj = (uint, 'c) obj
93      type 'c sshort_obj = (sshort, unit, 'c) obj      type 'c sshort_obj = (sshort, 'c) obj
94      type 'c ushort_obj = (ushort, unit, 'c) obj      type 'c ushort_obj = (ushort, 'c) obj
95      type 'c slong_obj = (slong, unit, 'c) obj      type 'c slong_obj = (slong, 'c) obj
96      type 'c ulong_obj = (ulong, unit, 'c) obj      type 'c ulong_obj = (ulong, 'c) obj
97      type 'c float_obj = (float, unit, 'c) obj      type 'c float_obj = (float, 'c) obj
98      type 'c double_obj = (double, unit, 'c) obj      type 'c double_obj = (double, 'c) obj
99      type 'c voidptr_obj = (voidptr, unit, 'c) obj      type 'c voidptr_obj = (voidptr, 'c) obj
100      type ('f, 'c) fptr_obj = ('f fptr, 'f, 'c) obj      type ('f, 'c) fptr_obj = ('f fptr, 'c) obj
101      type ('s, 'c) su_obj = ('s su, unit, 'c) obj      type ('s, 'c) su_obj = ('s su, 'c) obj
102    
103      type 'c schar_obj' = (schar, unit, 'c) obj'      type 'c schar_obj' = (schar, 'c) obj'
104      type 'c uchar_obj' = (uchar, unit, 'c) obj'      type 'c uchar_obj' = (uchar, 'c) obj'
105      type 'c sint_obj' = (sint, unit, 'c) obj'      type 'c sint_obj' = (sint, 'c) obj'
106      type 'c uint_obj' = (uint, unit, 'c) obj'      type 'c uint_obj' = (uint, 'c) obj'
107      type 'c sshort_obj' = (sshort, unit, 'c) obj'      type 'c sshort_obj' = (sshort, 'c) obj'
108      type 'c ushort_obj' = (ushort, unit, 'c) obj'      type 'c ushort_obj' = (ushort, 'c) obj'
109      type 'c slong_obj' = (slong, unit, 'c) obj'      type 'c slong_obj' = (slong, 'c) obj'
110      type 'c ulong_obj' = (ulong, unit, 'c) obj'      type 'c ulong_obj' = (ulong, 'c) obj'
111      type 'c float_obj' = (float, unit, 'c) obj'      type 'c float_obj' = (float, 'c) obj'
112      type 'c double_obj' = (double, unit, 'c) obj'      type 'c double_obj' = (double, 'c) obj'
113      type 'c voidptr_obj' = (voidptr, unit, 'c) obj'      type 'c voidptr_obj' = (voidptr, 'c) obj'
114      type ('f, 'c) fptr_obj' = ('f fptr, 'f, 'c) obj'      type ('f, 'c) fptr_obj' = ('f fptr, 'c) obj'
115      type ('s, 'c) su_obj' = ('s su, unit, 'c) obj'      type ('s, 'c) su_obj' = ('s su, 'c) obj'
116    
117      type 'c ubf = bf      type 'c ubf = bf
118      type 'c sbf = bf      type 'c sbf = bf
# Line 200  Line 200 
200    
201      structure T = struct      structure T = struct
202    
203          type ('t, 'f) typ = 'f objt          type 't typ = objt
204    
205          type schar_typ = (schar, unit) typ          fun typeof (_: addr, t: objt) = t
         type uchar_typ = (uchar, unit) typ  
         type sint_typ = (sint, unit) typ  
         type uint_typ = (uint, unit) typ  
         type sshort_typ = (sshort, unit) typ  
         type ushort_typ = (ushort, unit) typ  
         type slong_typ = (slong, unit) typ  
         type ulong_typ = (ulong, unit) typ  
         type float_typ = (float, unit) typ  
         type double_typ = (double, unit) typ  
         type voidptr_typ = (voidptr, unit) typ  
         type 'f fptr_typ = ('f fptr, 'f) typ  
         type 's su_typ = ('s su, unit) typ  
   
         fun typeof (_: addr, t: 'f objt) = t  
206    
207          fun sizeof (BASE b) = b          fun sizeof (BASE b) = b
208            | sizeof (PTR _) = S.ptr            | sizeof (PTR _) = S.ptr
# Line 238  Line 224 
224          end          end
225          fun elem (ARR a) = #typ a          fun elem (ARR a) = #typ a
226            | elem _ = bug "T.elem (non-array type)"            | elem _ = bug "T.elem (non-array type)"
227          fun ro (t: 'f objt) = t          fun ro (t: objt) = t
228    
229          val schar  = BASE S.schar          val schar  = BASE S.schar
230          val uchar  = BASE S.uchar          val uchar  = BASE S.uchar
# Line 264  Line 250 
250          val obj = pair_type_addr          val obj = pair_type_addr
251          val ptr = pair_type_addr          val ptr = pair_type_addr
252    
253          fun fptr (FPTR mkf) p = (p, mkf p)          fun fptr (FPTR mkf) p = (p, Unsafe.cast mkf p)
254            | fptr _ _ = bug "Heavy.fptr (non-function-pointer-type)"            | fptr _ _ = bug "Heavy.fptr (non-function-pointer-type)"
255      end      end
256    
# Line 326  Line 312 
312          fun ptr (a, PTR t) = (CMemory.load_addr a, t)          fun ptr (a, PTR t) = (CMemory.load_addr a, t)
313            | ptr _ = bug "Get.ptr (non-pointer)"            | ptr _ = bug "Get.ptr (non-pointer)"
314          fun fptr (a, FPTR mkf) =          fun fptr (a, FPTR mkf) =
315              let val fa = CMemory.load_addr a in (fa, mkf fa) end              let val fa = CMemory.load_addr a in (fa, Unsafe.cast mkf fa) end
316            | fptr _ = bug "Get.fptr (non-function-pointer)"            | fptr _ = bug "Get.fptr (non-function-pointer)"
317    
318          local          local
# Line 391  Line 377 
377    
378      fun copy' bytes { from, to } =      fun copy' bytes { from, to } =
379          CMemory.bcopy { from = from, to = to, bytes = bytes }          CMemory.bcopy { from = from, to = to, bytes = bytes }
380      fun copy { from = (from, t), to = (to, _: 'f objt) } =      fun copy { from = (from, t), to = (to, _: objt) } =
381          copy' (T.sizeof t) { from = from, to = to }          copy' (T.sizeof t) { from = from, to = to }
382    
383      structure Ptr = struct      structure Ptr = struct
# Line 406  Line 392 
392          val compare' = CMemory.compare          val compare' = CMemory.compare
393    
394          val inject' = addr_id          val inject' = addr_id
395          fun project' (_ : 'f objt) = addr_id          fun cast' (_ : objt) = addr_id
396    
397          val inject = p_strip_type          val inject = p_strip_type
398          fun project (PTR t) (p : voidptr) = (p, t)          fun cast (PTR t) (p : voidptr) = (p, t)
399            | project _ _ = bug "Ptr.project (non-pointer-type)"            | cast _ _ = bug "Ptr.cast (non-pointer-type)"
400    
401          val vNull = CMemory.null          val vNull = CMemory.null
402          fun null t = project t vNull          fun null t = cast t vNull
403          val null' = CMemory.null          val null' = CMemory.null
404    
405          val vIsNull = CMemory.isNull          val vIsNull = CMemory.isNull
# Line 424  Line 410 
410          fun |-! s (p, p') = (p -- p') div Word.toInt s          fun |-! s (p, p') = (p -- p') div Word.toInt s
411    
412          fun |+| ((p, t), i) = (|+! (T.sizeof t) (p, i), t)          fun |+| ((p, t), i) = (|+! (T.sizeof t) (p, i), t)
413          fun |-| ((p, t), (p', _: 'f objt)) = |-! (T.sizeof t) (p, p')          fun |-| ((p, t), (p', _: objt)) = |-! (T.sizeof t) (p, p')
414    
415          fun sub (p, i) = |*| (|+| (p, i))          fun sub (p, i) = |*| (|+| (p, i))
416    
# Line 461  Line 447 
447          fun dim (_: addr, t) = T.dim t          fun dim (_: addr, t) = T.dim t
448      end      end
449    
450      fun new'' s = CMemory.alloc s      fun new' s = CMemory.alloc s
451      fun new' t = CMemory.alloc (T.sizeof t)      fun new t = Option.map (fn a => (a, t)) (new' (T.sizeof t))
     fun new t = Option.map (fn a => (a, t)) (new' t)  
452    
453      val discard' = CMemory.free      val discard' = CMemory.free
454      fun discard x = discard' (p_strip_type x)      fun discard x = discard' (p_strip_type x)
455    
456      fun alloc'' s i = CMemory.alloc (s * i)      fun alloc' s i = CMemory.alloc (s * i)
457      fun alloc' t i = CMemory.alloc (T.sizeof t * i)      fun alloc t i = Option.map (fn p => (p, t)) (alloc' (T.sizeof t) i)
     fun alloc t i = Option.map (fn p => (p, t)) (alloc' t i)  
458    
459      val free' = CMemory.free      val free' = CMemory.free
460      fun free x = free' (p_strip_type x)      fun free x = free' (p_strip_type x)
461    
462      fun call ((_: addr, f), x) = f x      fun call ((_: addr, f), x) = f x
463    
464      fun call' (FPTR mkf) (a, x) = mkf a x      fun call' (FPTR mkf) (a, x) = Unsafe.cast mkf a x
465        | call' _ _ = bug "call' (non-function-pointer-type)"        | call' _ _ = bug "call' (non-function-pointer-type)"
466    
467      (* ------------- internal stuff ------------- *)      (* ------------- internal stuff ------------- *)
468    
469      fun mk_obj (t: 'f objt) (a: addr) = (a, t)      fun mk_obj (t: objt) (a: addr) = (a, t)
470      fun mk_voidptr (a : addr) = a      fun mk_voidptr (a : addr) = a
471      fun mk_fptr (FPTR mkf) a = (a, mkf a)      fun mk_fptr (FPTR mkf) a = (a, Unsafe.cast mkf a)
472        | mk_fptr _ _ = bug "mk_fptr (non-function-pointer-type)"        | mk_fptr _ _ = bug "mk_fptr (non-function-pointer-type)"
473    
474      local      local
475          fun mk_field (t: 'f objt) i (a, _: 'x objt) = (a ++ i, t)          fun mk_field (t: objt) i (a, _: objt) = (a ++ i, t)
476      in      in
477          val mk_rw_field = mk_field          val mk_rw_field = mk_field
478          val mk_ro_field = mk_field          val mk_ro_field = mk_field
# Line 507  Line 491 
491    
492              { a = a, l = l, r = r, lr = lr, m = m, im = im } : bf              { a = a, l = l, r = r, lr = lr, m = m, im = im } : bf
493          end          end
494          fun mk_bf acc (a, _: 'x objt) = mk_bf' acc a          fun mk_bf acc (a, _: objt) = mk_bf' acc a
495      in      in
496          val mk_rw_ubf = mk_bf          val mk_rw_ubf = mk_bf
497          val mk_ro_ubf = mk_bf          val mk_ro_ubf = mk_bf
# Line 522  Line 506 
506    
507      fun mk_su_size sz = sz      fun mk_su_size sz = sz
508      fun mk_su_typ sz = BASE sz      fun mk_su_typ sz = BASE sz
509      fun mk_fptr_typ (mkf: addr -> 'a -> 'b) = FPTR mkf      fun mk_fptr_typ (mkf: addr -> 'a -> 'b) = FPTR (Unsafe.cast mkf)
510    
511      val reveal = addr_id      val reveal = addr_id
512      val freveal = addr_id      val freveal = addr_id

Legend:
Removed from v.836  
changed lines
  Added in v.837

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