3
Copyright (C) 2006, 2007, 2008, 2009, 2010 Matthew Birkholz
5
This file is part of MIT/GNU Scheme.
7
MIT/GNU Scheme is free software; you can redistribute it and/or modify
8
it under the terms of the GNU General Public License as published by
9
the Free Software Foundation; either version 2 of the License, or (at
10
your option) any later version.
12
MIT/GNU Scheme is distributed in the hope that it will be useful, but
13
WITHOUT ANY WARRANTY; without even the implied warranty of
14
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15
General Public License for more details.
17
You should have received a copy of the GNU General Public License
18
along with MIT/GNU Scheme; if not, write to the Free Software
19
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
24
;;;; Aliens and Alien Functions
25
;;; package: (runtime ffi)
27
(declare (usual-integrations))
32
(define-structure (alien (constructor %make-alien)
37
(high-bits 0) (low-bits 0)
41
;; Breaking a word in two produces high and low fixnums. If they are
42
;; two digits representing a larger number, then RADIX is their base.
43
;; For a 32 bit word, (radix) is #x10000.
45
;; This substitutes a constant when there is a compiler, per its
46
;; target. Else this is a reference to %radix.
49
(lambda (form rename compare)
50
(declare (ignore rename compare))
51
(if (not (null? (cdr form)))
52
(syntax-error "No sub-forms allowed:" form))
53
(cond ((get-subsystem-version "LIAR/i386") #x10000)
54
((get-subsystem-version "LIAR/x86-64") #x100000000)
58
;; This is only needed when the target machine's word size is unknown
59
;; (e.g. when compiling to C, or when there is no compiler).
62
(set-record-type-unparser-method! rtd:alien
63
(standard-unparser-method
66
(write-char #\space port)
67
(write (%alien/ctype alien) port)
68
(write-string " 0x" port)
69
(write-string (alien/address-string alien) port))))
71
(define-integrable alien/ctype %alien/ctype)
73
(define-integrable set-alien/ctype! set-%alien/ctype!)
75
(declare (integrate-operator c-cast))
76
(define (c-cast alien ctype)
77
(set-%alien/ctype! alien ctype)
80
(define (alien/address-string alien)
81
;; Returns a string, e.g. "081adc60".
82
(let ((high (%alien/high-bits alien))
83
(low (%alien/low-bits alien))
85
(string-pad-left (number->string n 16)
86
(if (fix:= (radix) #x10000) 4 8)
88
(string-append (hex high) (hex low))))
90
(define (make-alien #!optional ctype)
91
(let ((ctype (if (default-object? ctype) #f ctype)))
92
(%make-alien 0 0 ctype)))
94
(declare (integrate-operator alien/address))
95
(define (alien/address alien)
96
(+ (* (%alien/high-bits alien) (radix))
97
(%alien/low-bits alien)))
99
(declare (integrate-operator copy-alien-address!))
100
(define (copy-alien-address! alien source)
101
(if (not (eq? alien source))
103
(set-%alien/high-bits! alien (%alien/high-bits source))
104
(set-%alien/low-bits! alien (%alien/low-bits source)))))
106
(declare (integrate-operator alien-null?))
107
(define (alien-null? alien)
108
(and (fix:zero? (%alien/high-bits alien))
109
(fix:zero? (%alien/low-bits alien))))
111
(declare (integrate-operator alien-null!))
112
(define (alien-null! alien)
113
(set-%alien/high-bits! alien 0)
114
(set-%alien/low-bits! alien 0))
116
(define null-alien (make-alien '|void|))
118
(declare (integrate-operator alien=?))
119
(define (alien=? alien1 alien2)
120
(and (fix:= (%alien/high-bits alien1) (%alien/high-bits alien2))
121
(fix:= (%alien/low-bits alien1) (%alien/low-bits alien2))))
123
(define (alien-hash alien modulus)
124
;; Appropriate for hash table construction (as is alien=?).
125
(remainder (fix:xor (%alien/high-bits alien)
126
(%alien/low-bits alien)) modulus))
128
(define (alien-byte-increment alien offset #!optional ctype)
129
;; Returns a new alien - a copy of ALIEN - whose address is OFFSET
130
;; bytes from ALIEN's. If CTYPE is specified, the type slot of the
132
(let ((new (copy-alien alien)))
133
(alien-byte-increment! new offset)
134
(if (not (default-object? ctype))
135
(set-%alien/ctype! new ctype))
138
(define (alien-byte-increment! alien increment #!optional ctype)
139
;; This procedure returns ALIEN after modifying it to have an
140
;; address INCREMENT bytes away from its previous address. If CTYPE
141
;; is specified, the type slot of ALIEN is set.
142
(let ((quotient.remainder (fix:divide increment (radix))))
143
(let ((new-high (fix:+ (%alien/high-bits alien)
144
(integer-divide-quotient quotient.remainder)))
145
(new-low (fix:+ (%alien/low-bits alien)
146
(integer-divide-remainder quotient.remainder))))
147
(cond ((fix:negative? new-high)
148
(error:bad-range-argument increment 'alien-byte-increment!))
149
((fix:negative? new-low)
150
(if (fix:zero? new-high)
151
(error:bad-range-argument increment 'alien-byte-increment!)
153
(set-%alien/low-bits! alien (fix:+ new-low (radix)))
154
(set-%alien/high-bits! alien (fix:-1+ new-high)))))
155
((fix:>= new-low (radix))
156
(set-%alien/low-bits! alien (fix:- new-low (radix)))
157
(set-%alien/high-bits! alien (fix:1+ new-high)))
159
(set-%alien/low-bits! alien new-low)
160
(set-%alien/high-bits! alien new-high)))))
161
(if (not (default-object? ctype))
162
(set-%alien/ctype! alien ctype))
165
(declare (integrate-operator guarantee-alien))
166
(define (guarantee-alien object operator)
167
(if (not (alien? object))
168
(error:not-alien object operator)))
170
(define (error:not-alien object operator)
171
(call-with-current-continuation
172
(lambda (continuation)
175
"Continue with an alien." ;reporter
176
continuation ;effector
177
(lambda () ;interactor
179
(prompt-for-evaluated-expression
180
"New alien (an expression to be evaluated)")))
182
(error:wrong-type-argument object "an alien" operator))))))
187
(define-structure (alien-function
188
(constructor %make-alien-function)
189
(conc-name %alien-function/)
190
(predicate alien-function?)
191
;; To be fasdump/loadable.
192
(type vector) (named 'alien-function)
194
(standard-unparser-method 'ALIEN-FUNCTION
195
(lambda (alienf port)
196
(write-char #\space port)
197
(write-string (%alien-function/name alienf)
200
;; C function entry address as two fixnums.
203
;; String: name of trampoline. (Starts with "Scm_".)
206
;; String: name of shim. (WithOUT "-shim.so" on the end.)
209
;; Caseful symbol or list, e.g. (* |GtkWidget|).
212
;; Alist of parameter names * types, e.g. ((widget (* |GtkWidget|))...)
215
;; Filename from which the EXTERN declaration was read.
221
(declare (integrate-operator guarantee-alien-function))
222
(define (guarantee-alien-function object operator)
223
(if (not (alien-function? object))
224
(error:not-alien-function object operator)))
226
(define (error:not-alien-function object operator)
227
(error:wrong-type-argument object "an alien function" operator))
229
(define (make-alien-function name library return-type params filename)
230
(%make-alien-function 0 0 (string-append "Scm_" name)
231
library return-type params filename #f))
233
(define-integrable alien-function/return-type %alien-function/return-type)
235
(define-integrable alien-function/parameters %alien-function/parameters)
237
(define-integrable alien-function/filename %alien-function/filename)
239
(define-integrable (alien-function/name alienf)
240
(string-tail (%alien-function/name alienf) 4))
242
(define (%set-alien-function/address! alienf address)
243
(let ((qr (integer-divide address (radix))))
244
(set-%alien-function/high-bits! alienf (integer-divide-quotient qr))
245
(set-%alien-function/low-bits! alienf (integer-divide-remainder qr))))
249
(define (reset-alien-functions!)
250
(set! band-id (list (get-universal-time))))
252
(define (alien-function-cache! afunc)
253
(if (eq? band-id (%alien-function/band-id afunc))
255
(let* ((library (%alien-function/library afunc))
256
(name (%alien-function/name afunc))
257
(pathname (merge-pathnames
258
(pathname-new-type (string-append library "-shim") "so")
259
(system-library-directory-pathname)))
260
(handle (or (find-dld-handle
262
(pathname=? pathname (dld-handle-pathname h))))
263
(dld-load-file pathname)))
264
(address (dld-lookup-symbol handle name)))
266
(%set-alien-function/address! afunc address)
267
(error:bad-range-argument afunc 'alien-function-cache!))
268
(set-%alien-function/band-id! afunc band-id))))
270
(define (c-peek-cstring alien)
271
((ucode-primitive c-peek-cstring 2) alien 0))
273
(define (c-peek-cstring! alien)
274
((ucode-primitive c-peek-cstring! 2) alien 0))
276
(define (c-peek-cstringp alien)
277
((ucode-primitive c-peek-cstringp 2) alien 0))
279
(define (c-peek-cstringp! alien)
280
((ucode-primitive c-peek-cstringp! 2) alien 0))
282
(define (c-poke-pointer dest alien)
283
;; Sets the pointer at the alien DEST to point to the ALIEN.
284
((ucode-primitive c-poke-pointer 3) dest 0 alien))
286
(define (c-poke-pointer! dest alien)
287
;; Like c-poke-pointer, but increments DEST by a pointer width.
288
((ucode-primitive c-poke-pointer! 3) dest 0 alien))
290
(define (c-poke-string alien string)
291
;; Copy STRING to the bytes at the ALIEN address.
292
(guarantee-string string 'C-POKE-STRING)
293
((ucode-primitive c-poke-string 3) alien 0 string))
295
(define (c-poke-string! alien string)
296
;; Like c-poke-string, but increments ALIEN by the null-terminated
298
(guarantee-string string 'C-POKE-STRING)
299
((ucode-primitive c-poke-string! 3) alien 0 string))
301
(define (c-enum-name value enum-name constants)
303
(let loop ((consts constants))
305
(error:bad-range-argument value 'c-enum-name)
306
(let ((name.value (car consts)))
307
(if (= value (cdr name.value))
309
(loop (cdr consts)))))))
311
(define (call-alien alien-function . args)
312
(guarantee-alien-function alien-function 'call-alien)
313
(alien-function-cache! alien-function)
316
(if (alien-function? arg)
317
(alien-function-cache! arg)))
321
(call-alien* alien-function args))))
323
(define (call-alien* alien-function args)
324
(let ((old-top calloutback-stack))
326
(outf-console ";"(tindent)"=> "alien-function" "args"\n")
327
(set! calloutback-stack (cons (cons* alien-function args) old-top)))
328
(let ((value (apply (ucode-primitive c-call -1) alien-function args)))
330
(assert (eq? old-top (cdr calloutback-stack))
331
"call-alien: freak stack "calloutback-stack"\n")
332
(set! calloutback-stack old-top)
333
(outf-console ";"(tindent)"<= "value"\n"))
339
;; Weak alist of: ( malloc alien X copy for c-free )...
340
(define malloced-aliens '())
342
(define (free-malloced-aliens)
343
(let loop ((aliens malloced-aliens)
346
(if (weak-pair/car? (car aliens))
347
(loop (cdr aliens) aliens)
348
(let ((copy (weak-cdr (car aliens)))
352
(set! malloced-aliens next))
353
(if (not (alien-null? copy))
355
((ucode-primitive c-free 1) copy)
357
(loop next prev))))))
359
(define (reset-malloced-aliens!)
360
(let loop ((aliens malloced-aliens))
362
(let ((alien (weak-car (car aliens)))
363
(copy (weak-cdr (car aliens))))
364
(if alien (alien-null! alien))
366
(loop (cdr aliens)))))
367
(set! malloced-aliens '()))
369
(define (make-alien-to-free ctype init)
370
;; Register BEFORE initializing (allocating).
371
(let ((alien (make-alien ctype)))
372
(let ((copy (make-alien ctype)))
373
(let ((entry (weak-cons alien copy)))
376
(set! malloced-aliens (cons entry malloced-aliens)))))
378
;; Even an abort here will not leak a byte.
379
(copy-alien-address! alien copy))
382
(define (malloc size ctype)
383
(make-alien-to-free ctype
385
((ucode-primitive c-malloc 2) alien size))))
388
(if (not (alien? alien))
389
(warn "Cannot free a non-alien:" alien)
390
(let ((weak (weak-assq alien malloced-aliens)))
392
(warn "Cannot free an alien that was not malloced:" alien)
393
(let ((copy (weak-cdr weak)))
396
(if (not (alien-null? alien))
399
((ucode-primitive c-free 1) copy)
400
(alien-null! copy))))))))))
402
(define (weak-assq obj alist)
403
(let loop ((alist alist))
405
(let* ((entry (car alist))
406
(key (weak-car entry)))
407
(if (eq? obj key) entry
408
(loop (cdr alist)))))))
413
(define registered-callbacks)
414
(define first-free-id)
416
(define (reset-callbacks!)
417
(set! registered-callbacks (make-vector 100 #f))
418
(set! first-free-id 1))
420
(define (register-c-callback procedure)
421
(if (not (procedure? procedure))
422
(error:wrong-type-argument procedure "a procedure" 'register-c-callback))
425
(let ((id first-free-id))
426
(set! first-free-id (next-free-id (1+ id)))
427
(vector-set! registered-callbacks id procedure)
430
(define (next-free-id id)
431
(let ((len (vector-length registered-callbacks)))
432
(let next-id ((id id))
434
(set! registered-callbacks
435
(vector-grow registered-callbacks (* 2 len)))
437
((not (vector-ref registered-callbacks id)) id)
438
;; When not recycling ids, the above is always true.
439
;; There is no need for the next-id loop.
440
(else (next-id (1+ id)))))))
442
(define (de-register-c-callback id)
443
(vector-set! registered-callbacks id #f)
444
;; Uncomment to recycle ids.
445
;;(if (< id first-free-id)
446
;; (set! first-free-id id))
449
(define (normalize-aliens! args)
450
;; Any vectors among ARGS are assumed to be freshly-consed aliens
451
;; without their record-type. Fix them.
452
(let ((tag (record-type-dispatch-tag rtd:alien)))
453
(let loop ((args args))
456
(let ((arg (car args)))
457
(if (%record? arg) (%record-set! arg 0 tag))
458
(loop (cdr args)))))))
460
(define (callback-handler id args)
461
;; Installed in the fixed-objects-vector, this procedure is called
462
;; by a callback trampoline. The callout should have already masked
463
;; all but the GC interrupts.
465
(if (not (< id (vector-length registered-callbacks)))
466
(error:bad-range-argument id 'apply-callback))
467
(let ((procedure (vector-ref registered-callbacks id)))
469
(error:bad-range-argument id 'apply-callback))
470
(normalize-aliens! args)
471
(let ((old-top calloutback-stack))
473
(outf-console ";"(tindent)"=>> "procedure" "args"\n")
474
(set! calloutback-stack (cons (cons procedure args) old-top)))
475
(let ((value (apply-callback-proc procedure args)))
477
(assert (and (pair? calloutback-stack)
478
(eq? old-top (cdr calloutback-stack)))
479
"callback-handler: freak stack "calloutback-stack"\n")
480
(set! calloutback-stack old-top)
481
(outf-console ";"(tindent)"<<= "value"\n"))
484
(define (apply-callback-proc procedure args)
485
(call-with-current-continuation
489
"Return a value from the callback." ;reporter
491
(lambda () ;interactor
492
(values (prompt-for-evaluated-expression
493
"Value to return from callback")))
499
(apply procedure args))
501
(error "Cannot return from a callback more than once.")
504
;; For callback debugging...
505
(define (outf-console . objects)
506
((ucode-primitive outf-console 1)
508
(map (lambda (o) (if (string? o) o (write-to-string o)))
511
(define (initialize-callbacks!)
512
(vector-set! (get-fixed-objects-vector) #x41 callback-handler))
515
(define calloutback-stack '())
519
(define (reset-package!)
520
(reset-alien-functions!)
521
(reset-malloced-aliens!)
523
(set! %radix (if (fix:fixnum? #x100000000) #x100000000 #x10000))
525
(set! calloutback-stack '()))
527
(define (initialize-package!)
529
(initialize-callbacks!)
530
(add-event-receiver! event:after-restore reset-package!)
531
(add-gc-daemon! free-malloced-aliens)
534
(define-syntax if-tracing
537
(if trace? ((lambda () . BODY))))))
539
(define-syntax assert
542
(if (not TEST) (error "Failed assert:" . MSG)))))
547
(if trace? ((lambda () (outf-console . MSG)))))))
550
(make-string (* 2 (length calloutback-stack)) #\space))
b'\\ No newline at end of file'
added
removed
src/runtime/ffi.scm
