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/smlnj-c/c-calls.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-c/c-calls.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 250 - (view) (download)

1 : monnier 249 (* c-calls.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * SML/NJ interface for calling user C functions (SMLNJ-C)
6 :     *
7 :     * It is critical that this file agree with:
8 :     * runtime/c-libs/smlnj-ccalls/c-calls.h
9 :     * runtime/c-libs/smlnj-ccalls/c-calls.c
10 :     *)
11 :    
12 :     functor CCalls (structure CCInfo : CC_INFO) : C_CALLS =
13 :     struct
14 :     structure U = Unsafe
15 :     structure UC = U.CInterface
16 :    
17 :     val maxWordSzB = 4
18 :    
19 :     type word = Word32.word
20 :    
21 :     structure C = CCInfo
22 :    
23 :     (* assert that the C types are not larger than 32 bits *)
24 :     val _ = if (C.longSzB > maxWordSzB) orelse
25 :     (C.intSzB > maxWordSzB) orelse
26 :     (C.ptrSzB > maxWordSzB)
27 :     then
28 :     raise General.Fail "size of C word too big for SMLNJ-C"
29 :     else ();
30 :    
31 :     val NArgs = 15 (* must agree with c-calls.h & c-calls.c *)
32 :    
33 :     val say : string -> unit = print
34 :    
35 :     (* implementation of an abstract pointer type *)
36 :     structure CAddress :> sig eqtype caddr
37 :     val NULL : caddr
38 :     val index : (caddr * int) -> caddr
39 :     val difference : (caddr * caddr) -> word
40 :     end =
41 :     struct
42 :     type caddr = word
43 :    
44 :     val NULL : word = 0w0
45 :    
46 :     (* index and difference assume pointers to bytes *)
47 :     fun index (p:caddr,i:int) = Word32.+(p,(Word32.fromInt i))
48 :     fun difference (p:caddr,q:caddr) =
49 :     Word32.-(p,q)
50 :     end
51 :     open CAddress
52 :    
53 :     (* NOTE: order (i.e. naming) of this data type is critical
54 :     * because the C side of the interface (c-calls.c, c-calls.h, etc.)
55 :     * makes assumptions about variant tags.
56 :     *)
57 :     datatype cdata =
58 :     Caddr of caddr
59 :     | Carray of cdata Array.array
60 :     | Cchar of char
61 :     | Cdouble of real
62 :     | Cfloat of real
63 :     | Cfunction of cdata list -> cdata
64 :     | Cint of word
65 :     | Clong of word
66 :     | Cptr of cdata
67 :     | Cshort of Word32.word
68 :     | Cstring of string (* 'char *' *)
69 :     | Cstruct of cdata list
70 :     | Cunion of cdata
71 :     | Cvector of cdata Vector.vector
72 :     | Cvoid
73 :    
74 :     datatype ctype =
75 :     CaddrT
76 :     | CarrayT of (int * ctype)
77 :     | CcharT
78 :     | CdoubleT
79 :     | CfloatT
80 :     | CfunctionT of (ctype list * ctype)
81 :     | CintT
82 :     | ClongT
83 :     | CptrT of ctype
84 :     | CshortT
85 :     | CstringT
86 :     | CstructT of ctype list
87 :     | CunionT of ctype list
88 :     | CvectorT of (int * ctype)
89 :     | CvoidT
90 :    
91 :     (* ctype' is the rewritten representation of ctype that extends
92 :     * the latter with size and (sometimes) with alignment information.
93 :     *)
94 :     datatype ctype' =
95 :     CaddrT'
96 :     | CarrayT' of {nelems:int,elemtyp:layout}
97 :     | CcharT'
98 :     | CdoubleT'
99 :     | CfloatT'
100 :     | CfunctionT' of {argtypes:layout list,rettype:layout}
101 :     | CintT'
102 :     | ClongT'
103 :     | CptrT' of layout
104 :     | CshortT'
105 :     | CstringT'
106 :     | CstructT' of layout list
107 :     | CunionT' of layout list
108 :     | CvectorT' of {nelems:int,elemtyp:layout}
109 :     | CvoidT'
110 :     | padT'
111 :     withtype layout = {typ:ctype',size:int,align:int option}
112 :    
113 :     val arrayCode = "A"
114 :     val intCode = "I"
115 :     val shortCode = "i" (* baby int *)
116 :     val longCode = "L"
117 :     val charCode = "C"
118 :     val doubleCode = "D"
119 :     val floatCode = "R"
120 :     val functionCode = "F"
121 :     val addrCode = "@"
122 :     val stringCode = "S"
123 :     val openStructCode = "("
124 :     val closeStructCode = ")"
125 :     val openUnionCode = "<"
126 :     val closeUnionCode = ">"
127 :     val vectorCode = "B"
128 :     val voidCode = "V"
129 :     val ptrCode = "P"
130 :     val padCode = "#"
131 :    
132 :     val cat = String.concat
133 :     val largest = foldr Int.max 0
134 :     val sum = foldr (op +) 0
135 :    
136 :     fun forAll _ [] = true
137 :     | forAll p (x::xs) = (p x) andalso (forAll p xs)
138 :    
139 :     exception EmptyAggregate
140 :     exception AggregateTooBig
141 :    
142 :     fun hasType (Caddr _) = CaddrT
143 :     | hasType (Carray a) =
144 :     (* how to handle 0-length arrays? *)
145 :     CarrayT(Array.length a,
146 :     hasType(Array.sub(a,0)) handle Subscript => CvoidT)
147 :     | hasType (Cchar _) = CcharT
148 :     | hasType (Cdouble _) = CdoubleT
149 :     | hasType (Cfloat _) = CfloatT
150 :     | hasType (Cshort _) = CshortT
151 :     | hasType (Cint _) = CintT
152 :     | hasType (Clong _) = ClongT
153 :     | hasType (Cptr p) = CptrT (hasType p)
154 :     | hasType (Cstring _) = CstringT
155 :     | hasType (Cstruct l) = CstructT (map hasType l)
156 :     | hasType (Cunion u) = CunionT [hasType u]
157 :     | hasType (Cvector v) =
158 :     (* how to handle 0-length vectors? *)
159 :     CvectorT(Vector.length v,
160 :     hasType(Vector.sub(v,0)) handle Subscript => CvoidT)
161 :     | hasType Cvoid = CvoidT
162 :    
163 :     fun dataSz (Cint _) = C.intSzB
164 :     | dataSz (Cshort _) = C.shortSzB
165 :     | dataSz (Clong _) = C.longSzB
166 :     | dataSz (Cstring s) = (String.size s)*C.charSzB + 1
167 :     | dataSz (Cchar _) = C.charSzB
168 :     | dataSz (Cdouble _) = C.doubleSzB
169 :     | dataSz (Cfloat _) = C.floatSzB
170 :    
171 :     fun stringSpace (Cstring s) = size s + 1
172 :     | stringSpace (Carray a) =
173 :     ((stringSpace (Array.sub(a,0))) handle Subscript => 0)
174 :     | stringSpace (Cstruct l) = sum (map stringSpace l)
175 :     | stringSpace (Cunion u) = stringSpace u
176 :     | stringSpace (Cvector a) =
177 :     ((stringSpace (Vector.sub(a,0))) handle Subscript => 0)
178 :     | stringSpace _ = 0
179 :    
180 :     (* alignment/padding computations for the C side *)
181 :     (* see "C -- A Reference Manual" by S. Harbison and G. Steele, Jr.
182 :     * for details on how C aligns union/struct members and array elems.
183 :     *)
184 :     (* put these into rewrite if that's the only place they're used *)
185 :     fun roundUp (i,align) =
186 :     let val r = Int.rem(i,align)
187 :     in if r = 0 then i else (i div align + 1) * align
188 :     end
189 :    
190 :     fun computePadSz (sz,align) = roundUp(sz,align)-sz
191 :     fun mkPad size = {typ=padT',size=size,align=NONE}
192 :    
193 :     fun memberAlign init l =
194 :     foldr (fn ({align=SOME al,size,typ},b) => Int.max (al,b)
195 :     | (_,b) => b) init l
196 :    
197 :     fun foldMemberSize f init =
198 :     foldr (fn ({align,size,typ},b) => f(size,b)) init
199 :    
200 :     fun memberSum x = foldMemberSize (op +) 0 x
201 :     fun memberMax x = foldMemberSize Int.max 0 x
202 :    
203 :     (* rewrite: ctype -> {typ:ctype',size:int,align:int option} *)
204 :     (* size is the size of the ctype thing
205 :     * NOT including the size of pointed-to sub-structure
206 :     * e.g., sub-structure of Cptrs or Cstrings
207 :     *)
208 :     fun rewrite CaddrT = {typ=CaddrT',size=C.ptrSzB,align=SOME C.ptrSzB}
209 :     | rewrite (CarrayT (n,t)) =
210 :     let val t' as {align,size,typ} = rewrite t
211 :     in {typ=CarrayT'{nelems=n,elemtyp=t'},size=n*size,align=align}
212 :     end
213 :     | rewrite CcharT = {typ=CcharT',size=C.charSzB,align=SOME C.charSzB}
214 :     | rewrite CdoubleT = {typ=CdoubleT',size=C.doubleSzB,
215 :     align=SOME C.doubleSzB}
216 :     | rewrite CfloatT = {typ=CfloatT',size=C.floatSzB,
217 :     align=SOME C.floatSzB}
218 :     | rewrite CintT = {typ=CintT',size=C.intSzB,align=SOME C.intSzB}
219 :     | rewrite CshortT = {typ=CshortT',size=C.shortSzB,align=SOME C.shortSzB}
220 :     | rewrite ClongT = {typ=ClongT',size=C.longSzB,align=SOME C.longSzB}
221 :     | rewrite (CptrT t) =
222 :     let val t' = rewrite t
223 :     in {typ=CptrT' t',size=C.ptrSzB,align=SOME C.ptrSzB}
224 :     end
225 :     | rewrite CstringT = {typ=CstringT',size=C.ptrSzB,
226 :     align=SOME C.ptrSzB}
227 :     | rewrite (CunionT l) =
228 :     let val l' = map rewrite l
229 :     val al = memberAlign 0 l'
230 :     val sz = roundUp(memberMax l',al)
231 :     in {typ=CunionT' l',size=sz,align=SOME al}
232 :     end
233 :     | rewrite (CstructT l) =
234 :     let val l' = map rewrite l
235 :     val al = memberAlign 0 l'
236 :     fun addPads ([],acc) = []
237 :     | addPads ((x as {typ,size,align=SOME al})::xs,acc) =
238 :     let val slack = computePadSz (acc,al)
239 :     val res = x::(addPads (xs,acc+slack+size))
240 :     in if slack = 0 then res
241 :     else mkPad slack :: res
242 :     end
243 :     val l'' = addPads (l',0)
244 :     val sz = memberSum l''
245 :     val extra = computePadSz (sz,al)
246 :     val l''' = if extra=0 then l'' else l'' @ [mkPad extra]
247 :     in
248 :     {typ=CstructT' l''',size=roundUp(sz,al),align=SOME al}
249 :     end
250 :     | rewrite (CfunctionT (argtypes,rettype)) =
251 :     let val atypes = map rewrite argtypes
252 :     val rtype = rewrite rettype
253 :     in {typ=CfunctionT'{argtypes=map rewrite argtypes,
254 :     rettype=rewrite rettype},
255 :     size=C.ptrSzB,align=SOME C.ptrSzB}
256 :     end
257 :     | rewrite (CvectorT (n,t)) =
258 :     let val t' as {align,size,typ} = rewrite t
259 :     in {typ=CvectorT'{nelems=n,elemtyp=t'},size=n*size,align=align}
260 :     end
261 :     | rewrite CvoidT = {typ=CvoidT',size=0,align=NONE}
262 :    
263 :     fun typeToCtl arg =
264 :     let val charRange = 255 (* not 256 since 0 is C string delim *)
265 :     fun uToS bytes c = (* unsigned int to string *)
266 :     let fun aux (0,i,acc) = if i <> 0 then raise AggregateTooBig
267 :     else acc
268 :     | aux (n,i,acc) =
269 :     let val q = i div charRange
270 :     val r = i mod charRange + 1
271 :     in aux(n-1,q,String.str(Char.chr r) ^ acc)
272 :     end
273 :     in aux (bytes,c,"")
274 :     end
275 :     fun aux {typ=CaddrT',...} = addrCode
276 :     | aux {typ=CarrayT'{nelems,elemtyp=elemtyp as {size,...}},
277 :     ...} =
278 :     arrayCode^(uToS 2 nelems)^(uToS 2 size)^(aux elemtyp)
279 :     | aux {typ=CintT',size,...} = intCode^(uToS 1 size)
280 :     | aux {typ=CshortT',size,...} = shortCode^(uToS 1 size)
281 :     | aux {typ=ClongT',size,...} = longCode^(uToS 1 size)
282 :     | aux {typ=CcharT',...} = charCode
283 :     | aux {typ=CdoubleT',...} = doubleCode
284 :     | aux {typ=CfloatT',...} = floatCode
285 :     | aux {typ=CfunctionT'{argtypes,rettype},...} =
286 :     functionCode^(uToS 1 (length argtypes))^
287 :     (cat (map aux argtypes))^(aux rettype)
288 :     | aux {typ=CptrT' (t as {size,align=SOME al,...}),...} =
289 :     ptrCode^(uToS 4 size)^(uToS 1 al)^(aux t)
290 :     | aux {typ=CstringT',...} = stringCode
291 :     | aux {typ=CstructT' [],...} = raise EmptyAggregate
292 :     | aux {typ=CstructT' l,size,...} =
293 :     (* need to put size in here (?) *)
294 :     openStructCode^(cat (map aux l))^closeStructCode
295 :     | aux {typ=CunionT' [],...} = raise EmptyAggregate
296 :     | aux {typ=CunionT' l,size,...} =
297 :     openUnionCode^(uToS 1 size)^(cat (map aux l))^
298 :     closeUnionCode
299 :     | aux {typ=CvectorT'{nelems,elemtyp=elemtyp as {size,...}},
300 :     ...} =
301 :     vectorCode^(uToS 2 nelems)^(uToS 2 size)^(aux elemtyp)
302 :     | aux {typ=CvoidT',...} = voidCode
303 :     | aux {typ=padT',size,...} = padCode^(uToS 1 size)
304 :     in aux arg
305 :     end
306 :    
307 :     val libname = "SMLNJ-CCalls"
308 :     fun cfun x = UC.c_function libname x
309 :    
310 :     (** (* for debugging *)
311 :     fun cfun s = (print "binding C function '";
312 :     print s;
313 :     print "'\n";
314 :     UC.c_function libname s)
315 :     **)
316 :    
317 :     fun cbind (mf as (moduleName, funName)) =
318 :     let val f = UC.bindCFun mf
319 :     in
320 :     if (U.cast f <> 0) then U.cast f
321 :     else (print ("can't find "^moduleName ^ "." ^ funName^"\n");
322 :     raise UC.CFunNotFound(moduleName ^ "." ^ funName))
323 :     end
324 :    
325 :     type arg_desc = string (* type requirement *)
326 :    
327 :     fun mkArgDesc t = typeToCtl (rewrite t)
328 :    
329 :     type dummy = unit
330 :    
331 :     val CFnDoCCall : ((dummy -> dummy) *
332 :     int *
333 :     arg_desc list *
334 :     arg_desc *
335 :     cdata list *
336 :     bool) -> (cdata * caddr list) = cfun "c_call"
337 :    
338 :     exception BadReturnType of ctype
339 :     exception BadArgumentType of ctype
340 :     exception NotAPtr of ctype
341 :     exception UnimplementedForType
342 :     exception TooManyArgs of int
343 :    
344 :     (* valid return types are types are "ground" types *)
345 :     fun validRetType CintT = true
346 :     | validRetType CshortT = C.shortSzB = C.intSzB
347 :     | validRetType ClongT = C.longSzB = C.intSzB
348 :     | validRetType CvoidT = true
349 :     | validRetType CstringT = true
350 :     | validRetType CaddrT = true
351 :     | validRetType CfloatT = true
352 :     | validRetType CdoubleT = true
353 :     | validRetType (CptrT _) = true
354 :     | validRetType CcharT = true
355 :     | validRetType _ = false
356 :    
357 :     fun validFunctionTypes (CfunctionT (args,ret)) =
358 :     validRetType ret andalso (forAll validArgType args)
359 :     | validFunctionTypes (CarrayT(_,t)) = validFunctionTypes t
360 :     | validFunctionTypes (CptrT t) = validFunctionTypes t
361 :     | validFunctionTypes (CstructT l) = forAll validFunctionTypes l
362 :     | validFunctionTypes (CunionT l) = forAll validFunctionTypes l
363 :     | validFunctionTypes (CvectorT(_,t)) = validFunctionTypes t
364 :     | validFunctionTypes _ = true
365 :     and validArgType CaddrT = true
366 :     | validArgType CintT = true
367 :     | validArgType CshortT = C.shortSzB = C.intSzB
368 :     | validArgType ClongT = C.longSzB = C.intSzB
369 :     | validArgType (p as CptrT _) = validFunctionTypes p
370 :     | validArgType CstringT = true
371 :     | validArgType (f as CfunctionT _) = validFunctionTypes f
372 :     | validArgType _ = false
373 :    
374 :     (* need to do something here about function types *)
375 :     fun validPtr (CptrT _) = true
376 :     | validPtr CstringT = true
377 :     | validPtr _ = false
378 :    
379 :     fun register freeFlag (name:string,args:ctype list,res:ctype) =
380 :     let val _ = (validRetType res) orelse (raise (BadReturnType res))
381 :     val _ = app (fn x => ((validArgType x) orelse
382 :     (raise (BadArgumentType x));
383 :     ())) args
384 :     val nargs = length args
385 :     val _ = (nargs > NArgs) andalso (raise (TooManyArgs nargs))
386 :     val f : dummy -> dummy = cbind (libname,name)
387 :     val args' = map mkArgDesc args
388 :     val res' = mkArgDesc res
389 :     in
390 :     (* say ("function \"" ^ name ^ "\" registered\n"); *)
391 :     fn x => CFnDoCCall (f,nargs,args',res',x,freeFlag)
392 :     handle (e as (OS.SysErr (msg,errno))) =>
393 :     (say ("C call error: "^msg);
394 :     raise e)
395 :     | x => raise x
396 :     end
397 :    
398 :     fun registerAutoFreeCFn args = #1 o (register true args)
399 :     val registerCFn = register false
400 :    
401 :     val CFnDatumMLtoC : arg_desc * cdata -> (caddr * caddr list) =
402 :     cfun "datumMLtoC"
403 :     fun datumMLtoC t =
404 :     let val _ = (validPtr t) orelse (raise (NotAPtr t))
405 :     val desc = mkArgDesc t
406 :     in
407 :     fn d => CFnDatumMLtoC (desc,d)
408 :     end
409 :    
410 :     val CFnDatumCtoML : arg_desc * caddr -> cdata = cfun "datumCtoML"
411 :     fun datumCtoML t =
412 :     let fun noFns (CfunctionT _) = false
413 :     | noFns (CstructT l) = forAll noFns l
414 :     | noFns (CunionT l) = forAll noFns l
415 :     | noFns (CarrayT (_,t)) = noFns t
416 :     | noFns (CvectorT (_,t)) = noFns t
417 :     | noFns _ = true
418 :     val _ = (validPtr t) orelse (raise (NotAPtr t))
419 :     val _ = (noFns t) orelse (raise UnimplementedForType)
420 :     val desc = mkArgDesc t
421 :     in
422 :     fn p => CFnDatumCtoML (desc,p)
423 :     end
424 :    
425 :    
426 :     (* sizeof : ctype -> int *)
427 :     (* returns the number of bytes to represent ctype as
428 :     * a basic C data structre, NOT including any substructure
429 :     * such as Cstrings or Cptrs
430 :     *)
431 :     val sizeof = #size o rewrite (* this is overkill *)
432 :    
433 :     (* sizeofDatum : cdata -> int *)
434 :     (* returns the number of bytes needed to represent cdata
435 :     * as a C data structure, INCLUDING substructure such
436 :     * as Cstrings and Cptrs
437 :     *
438 :     * Only basic (flat) types currently work.
439 :     *)
440 :     val sizeofDatum = dataSz
441 :    
442 :     local val free' = registerAutoFreeCFn("free",[CaddrT],CvoidT)
443 :     in fun free p = (free' [Caddr p]; ())
444 :     end
445 :    
446 :     end (* functor CCalls *)

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