suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* Exported `cvector-ptr'

Browse Source 
* Added `#:hold' to `_fun' for callbacks (will be changed to `#:keep'
  soon, but better to have a checkpoint)
* _cprocedure also has a `hold' argument, and is now using keyword
  arguments (it was getting crowded in the optional arguments
  department)
* Documented everything that changed, with a longish descrption for
  options for holding callback values.
* More tests, including tests for callbacks that would crash if the
  callback values are not held.

svn: r11931
This commit is contained in:
Eli Barzilay 2008-10-04 19:01:17 +00:00
parent f2756fca3c
commit 2886a95318
5 changed files with 196 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
collects/mzlib/foreign.ss
View File

@ -467,14 +467,26 @@
;; Creates a simple function type that can be used for callouts and callbacks,
;; optionally applying a wrapper function to modify the result primitive
;; (callouts) or the input procedure (callbacks).
(define* (_cprocedure itypes otype [abi #f] [wrapper #f])
(if wrapper
(define* (_cprocedure itypes otype
#:abi [abi #f] #:wrapper [wrapper #f] #:holder [holder #f])
(_cprocedure* itypes otype abi wrapper holder))
;; for internal use
(define held-callbacks (make-weak-hasheq))
(define (_cprocedure* itypes otype abi wrapper holder)
(define-syntax-rule (make-it wrap)
(make-ctype _fpointer
(lambda (x) (ffi-callback (wrapper x) itypes otype abi))
(lambda (x) (wrapper (ffi-call x itypes otype abi))))
(make-ctype _fpointer
(lambda (x) (ffi-callback x itypes otype abi))
(lambda (x) (ffi-call x itypes otype abi)))))
(lambda (x)
(let ([cb (ffi-callback (wrap x) itypes otype abi)])
(cond [(eq? holder #t) (hash-set! held-callbacks x cb)]
[(box? holder)
(let ([x (unbox holder)])
(set-box! holder
(if (or (null? x) (pair? x)) (cons cb x) cb)))]
[(procedure? holder) (holder cb)])
cb))
(lambda (x) (wrap (ffi-call x itypes otype abi)))))
(if wrapper (make-it wrapper) (make-it begin)))
;; Syntax for the special _fun type:
;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
@ -500,6 +512,7 @@
(define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
(define xs #f)
(define abi #f)
(define holder #f)
(define inputs #f)
(define output #f)
(define bind '())
@ -557,15 +570,16 @@
;; parse keywords
(let loop ()
(let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))])
(when (keyword? k)
(define-syntax-rule (kwds [key var] ...)
(case k
[(#:abi) (if abi
(err "got a second #:abi keyword" (car xs))
(begin (set! abi (cadr xs))
(set! xs (cddr xs))
(loop)))]
[else (err "unknown keyword" (car xs))]))))
(unless abi (set! abi #'#f))
[(key) (if var
(err (format "got a second ~s keyword") 'key (car xs))
(begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
...
[else (err "unknown keyword" (car xs))]))
(when (keyword? k) (kwds [#:abi abi] [#:holder holder]))))
(unless abi (set! abi #'#f))
(unless holder (set! holder #'#t))
;; parse known punctuation
(set! xs (map (lambda (x)
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
@ -655,9 +669,10 @@
body 'inferred-name
(string->symbol (string-append "ffi-wrapper:" n)))
body))])
#`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi
(lambda (ffi) #,body)))
#`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi)))
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi (lambda (ffi) #,body) #,holder))
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi #f #,holder)))
(syntax-case stx ()
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
@ -961,7 +976,7 @@
(define-struct cvector (ptr type length))
(provide* cvector? cvector-length cvector-type
(provide* cvector? cvector-length cvector-type cvector-ptr
;; make-cvector* is a dangerous operation
(unsafe (rename-out [make-cvector make-cvector*])))
@ -1264,10 +1279,13 @@
;; Simple structs: call this with a list of types, and get a type that marshals
;; C structs to/from Scheme lists.
(define* (_list-struct . types)
(let ([stype (make-cstruct-type types)]
[offsets (compute-offsets types)])
(let ([stype (make-cstruct-type types)]
[offsets (compute-offsets types)]
[len (length types)])
(make-ctype stype
(lambda (vals)
(unless (and (list vals) (= len (length vals)))
(raise-type-error 'list-struct (format "list of ~a items" len) vals))
(let ([block (malloc stype)])
(for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val))
types offsets vals)

15
collects/scribblings/foreign/derived.scrbl
View File

@ -66,8 +66,8 @@ obtain a tag. The tag is the string form of @schemevarfont{id}.}
@declare-exporting[scribblings/foreign/unsafe-foreign]
@defproc*[([(cpointer-has-tag? [cptr any/c][tag any/c]) boolean?]
[(cpointer-push-tag! [cptr any/c][tag any/c]) void])]{
@defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?]
[(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{
These two functions treat pointer tags as lists of tags. As described
in @secref["foreign:pointer-funcs"], a pointer tag does not have any
@ -125,7 +125,12 @@ Returns the length of a C vector.}
Returns the C type object of a C vector.}
@defproc[(cvector-ref [cvec cvector?][k exact-nonnegative-integer?]) any]{
@defproc[(cvector-ptr [cvec cvector?]) cpointer?]{
Returns the pointer that points at the beginning block of the given C vector.}
@defproc[(cvector-ref [cvec cvector?] [k exact-nonnegative-integer?]) any]{
References the @scheme[k]th element of the @scheme[cvec] C vector.
The result has the type that the C vector uses.}
@ -154,7 +159,9 @@ Converts the list @scheme[lst] to a C vector of the given
@declare-exporting[scribblings/foreign/unsafe-foreign]
@defproc[(make-cvector* [cptr any/c][type ctype?][length exact-nonnegative-integer?]) cvector?]{
@defproc[(make-cvector* [cptr any/c] [type ctype?]
[length exact-nonnegative-integer?])
cvector?]{
Constructs a C vector using an existing pointer object. This
operation is not safe, so it is intended to be used in specific

96
collects/scribblings/foreign/types.scrbl
View File

@ -267,8 +267,14 @@ Otherwise, @scheme[_cprocedure] should be used (it is based on
@defproc[(_cprocedure [input-types (list ctype?)]
[output-type ctype?]
[abi (or/c symbol/c false/c) #f]
[wrapper (or false/c (procedure? . -> . procedure?)) #f]) any]{
[#:abi abi (or/c symbol/c false/c) #f]
[#:wrapper wrapper (or/c false/c
(procedure? . -> . procedure?))
#f]
[#:holder holder (or/c boolean? box?
(any/c . -> . any/c))
#t])
any]{
A type constructor that creates a new function type, which is
specified by the given @scheme[input-types] list and @scheme[output-type].
@ -286,27 +292,81 @@ function pointer that calls the given Scheme procedure when it is
used. There are no restrictions on the Scheme procedure; in
particular, its lexical context is properly preserved.
The optional @scheme[abi] argument determines the foreign ABI that is
used. @scheme[#f] or @scheme['default] will use a platform-dependent
default; other possible values are @scheme['stdcall] and
@scheme['sysv] (the latter corresponds to ``cdecl''). This is
especially important on Windows, where most system functions are
@scheme['stdcall], which is not the default.
The optional @scheme[abi] keyword argument determines the foreign ABI
that is used. @scheme[#f] or @scheme['default] will use a
platform-dependent default; other possible values are
@scheme['stdcall] and @scheme['sysv] (the latter corresponds to
``cdecl''). This is especially important on Windows, where most
system functions are @scheme['stdcall], which is not the default.
The optional @scheme[wrapper], if provided, is expected to be a function that
can change a callout procedure: when a callout is generated, the wrapper is
applied on the newly created primitive procedure, and its result is used as the
new function. Thus, @scheme[wrapper] is a hook that can perform various argument
manipulations before the foreign function is invoked, and return different
results (for example, grabbing a value stored in an ``output'' pointer and
returning multiple values). It can also be used for callbacks, as an
additional layer that tweaks arguments from the foreign code before they reach
the Scheme procedure, and possibly changes the result values too.}
The optional @scheme[wrapper], if provided, is expected to be a
function that can change a callout procedure: when a callout is
generated, the wrapper is applied on the newly created primitive
procedure, and its result is used as the new function. Thus,
@scheme[wrapper] is a hook that can perform various argument
manipulations before the foreign function is invoked, and return
different results (for example, grabbing a value stored in an
``output'' pointer and returning multiple values). It can also be
used for callbacks, as an additional layer that tweaks arguments from
the foreign code before they reach the Scheme procedure, and possibly
changes the result values too.
Sending Scheme functions as callbacks to foreign code is achieved by
translating them to a foreign ``closure'', which foreign code can call
as plain C functions. Additional care must be taken in case the
foreign code might hold on to the callback function. In these cases
you must arrange for the callback value to not be garbage-collected,
or the held callback will become invalid. The optional
@scheme[holder] keyword argument is used to achieve this. It can have
the following values:
@itemize[
@item{@scheme[#t] makes the callback value stay in memory as long as
the converted function is. In order to use this, you need to hold
on to the original function, for example, have a binding for it.
Note that each function can hold onto one callback value (it is
stored in a weak hash table), so if you need to use a function in
multiple callbacks you will need to use one of the the last two
options below. (This is the default, as it is fine in most cases.)}
@item{@scheme[#f] means that the callback value is not held. This may
be useful for a callback that is only used for the duration of the
foreign call --- for example, the comparison function argument to
the standard C library @tt{qsort} function is only used while
@tt{qsort} is working, and no additional references to the
comparison function are kept. Use this option only in such cases,
when no holding is necessary and you want to avoid the extra cost.}
@item{A box holding @scheme[#f] (or a callback value) --- in this case
the callback value will be stored in the box, overriding any value
that was in the box (making it useful for holding a single callback
value). When you know that it is no longer needed, you can
`release' the callback value by changing the box contents, or by
allowing the box itself to be garbage-collected. This is can be
useful if the box is held for a dynamic extent that corresponds to
when the callback is needed; for example, you might encapsulate some
foreign functionality in a Scheme class or a unit, and keep the
callback box as a field in new instances or instantiations of the
unit.}
@item{A box holding @scheme[null] (or any list) -- this is similar to
the previous case, except that new callback values are consed onto
the contents of the box. It is therefore useful in (rare) cases
when a Scheme function is used in multiple callbacks (that is, sent
to foreign code to hold onto multiple times).}
@item{Finally, if a one-argument function is provided as the
@scheme[holder], it will be invoked with the callback value when it
is generated. This allows you to grab the value directly and use it
in any way.}
]}
@defform/subs[#:literals (-> :: :)
(_fun fun-option ... maybe-args type-spec ... -> type-spec
maybe-wrapper)
([fun-option (code:line #:abi abi-expr)]
([fun-option (code:line #:abi abi-expr)
(code:line #:holder holder-expr)]
[maybe-args code:blank
(code:line (id ...) ::)
(code:line id ::)

21
collects/tests/mzscheme/foreign-test.c
View File

@ -57,3 +57,24 @@ X int use_g3(int x) { return ((int(*)(int))g3)(x); }
X int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); }
X int grab7th(void *p) { return ((char *)p)[7]; }
X int vec4(int x[]) { return x[0]+x[1]+x[2]+x[3]; }
typedef struct _char_int { unsigned char a; int b; } char_int;
X int charint_to_int(char_int x) { return ((int)x.a) + x.b; }
X char_int int_to_charint(int x) {
char_int result;
result.a = (unsigned char)x;
result.b = x;
return result;
}
X char_int charint_swap(char_int x) {
char_int result;
result.a = (unsigned char)x.b;
result.b = (int)x.a;
return result;
}
int(*grabbed_callback)(int) = NULL;
X void grab_callback(int(*f)(int)) { grabbed_callback = f; }
X int use_grabbed_callback(int n) { return grabbed_callback(n); }

89
collects/tests/mzscheme/foreign-test.ss
View File

@ -48,16 +48,19 @@
(compile-extension #t c o '())
(link-extension #t (list o) so)))
(let* ([lib (ffi-lib "./foreign-test")]
[ffi (lambda (name type) (get-ffi-obj name lib type))]
[test* (lambda (expected name type proc)
(test expected name (proc (ffi name type))))]
[t (lambda (expected name type . args)
(test* expected name type (lambda (p) (apply p args))))]
[tc (lambda (expected name type arg1 . args)
;; curry first argument
(test* expected name type (lambda (p) (apply (p arg1) args))))]
[sqr (lambda (x) (* x x))])
(define test-lib (ffi-lib "./foreign-test"))
(for ([n (in-range 5)])
(define (ffi name type) (get-ffi-obj name test-lib type))
(define (test* expected name type proc)
(test expected name (proc (ffi name type))))
(define (t expected name type . args)
(test* expected name type (lambda (p) (apply p args))))
(define (tc expected name type arg1 . args)
;; curry first argument
(test* expected name type (lambda (p) (apply (p arg1) args))))
(define (sqr x) (when (zero? (random 4)) (collect-garbage)) (* x x))
(define b (box #f))
;; ---
(t 2 'add1_int_int (_fun _int -> _int ) 1)
(t 2 'add1_byte_int (_fun _byte -> _int ) 1)
@ -98,7 +101,7 @@
(test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int))
(lambda (p) ((p (ffi 'add1_byte_byte (_fun _byte -> _byte)) 3) 10)))
;; ---
(set-ffi-obj! "g3" lib (_fun _int -> _int) add1)
(set-ffi-obj! "g3" test-lib (_fun _int -> _int) add1)
(t 4 'use_g3 (_fun _int -> _int) 3)
(test* 4 'g3 _pointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 3)))
;; ---
@ -120,11 +123,40 @@
(lambda (x y)
(let ([x (ptr-ref x _int)] [y (ptr-ref y _int)])
(cond [(< x y) -1] [(> x y) +1] [else 0])))))
;; ---
(t 55 'grab7th (_fun _pointer -> _int ) #"012345678")
(t 56 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" 1))
(t 52 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" -3))
;; test vectors
(t 55 'grab7th (_fun _pointer -> _int ) #"012345678")
(t 56 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" 1))
(t 52 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" -3))
(t 10 'vec4 (_fun (_list i _int) -> _int) '(1 2 3 4))
(t 10 'vec4 (_fun (_vector i _int) -> _int) '#(1 2 3 4))
(t 10 'vec4 (_fun _cvector -> _int) (list->cvector '(1 2 3 4) _int))
(t 10 'vec4 (_fun _pointer -> _int)
(cvector-ptr (list->cvector '(1 2 3 4) _int)))
;; ---
;; test passing and receiving structs
(let ([_charint (_list-struct _byte _int)])
(t 1212 'charint_to_int (_fun _charint -> _int) '(12 1200))
(t '(123 123) 'int_to_charint (_fun _int -> _charint) 123)
(t '(255 1) 'charint_swap (_fun _charint -> _charint) '(1 255)))
;; ---
;; test sending a callback for C to hold, preventing the callback from GCing
(let ([with-holder
(lambda (h)
(t (void) 'grab_callback
(_fun (_fun #:holder h _int -> _int) -> _void) sqr)
(t 9 'use_grabbed_callback (_fun _int -> _int) 3)
(collect-garbage) ; make sure it survives a GC
(t 25 'use_grabbed_callback (_fun _int -> _int) 5)
(collect-garbage)
(t 81 'use_grabbed_callback (_fun _int -> _int) 9))])
(with-holder #t)
(with-holder (box #f)))
;; ---
;; test exposing internal mzscheme functionality
(test '(1 2)
(get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme))
1 '(2))
)
;; test setting vector elements
@ -184,7 +216,6 @@ The following is some random Scheme and C code, with some things that should be
added.
-------------------------------------------------------------------------------
(define _foo (_list-struct (list _byte _int)))
(define foo-struct1
(get-ffi-obj "foo_struct1" "junk/foo.so" (_fun _foo -> _int)))
(define foo-struct2
@ -284,12 +315,6 @@ added.
(string-set! x2 1 #\X)
(foo-test "foo_string" '(#f) '(string) 'string)
(newline)
(printf ">>> scheme_make_pair(1,2) -> ~s\n"
((ffi-call (ffi-obj libself "scheme_make_pair")
'(scheme scheme) 'scheme)
1 2))
(newline)
(printf ">>> sizeof(int) = ~s\n" (ffi-size-of 'int))
'(let loop ((l '()))
@ -312,7 +337,6 @@ added.
(ffi-ptr-set! block1 'ulong 1 22)
(ffi-ptr-set! block1 'ulong 2 33)
(ffi-ptr-set! block1 'ulong 3 44)
(foo-test "foo_vect" (list block1) '(pointer) 'int)
;(ffi-ptr-set! block1 'ulong 'abs 1 22)
(printf ">>> [0] -> ~s\n" (ffi-ptr-ref block1 'ulong 0))
(printf ">>> [1] -> ~s\n" (ffi-ptr-ref block1 'ulong 1))
@ -393,26 +417,7 @@ char* foo_string (char* x) {
}
}
int foo_vect(int x[]) {
return x[0]+x[1]+x[2]+x[3];
}
int foo_foo(int x) { return x^1; }
typedef struct _char_int {
unsigned char a;
int b;
} char_int;
int foo_struct1(char_int x) {
return ((int)x.a) + x.b;
}
char_int foo_struct2(char_int x) {
char_int result;
result.a = (unsigned char)x.b;
result.b = (int)x.a;
return result;
}
-------------------------------------------------------------------------------
|#