From 2886a9531844f75faf563516447524bb893c9796 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 4 Oct 2008 19:01:17 +0000 Subject: [PATCH] * Exported `cvector-ptr' * 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 --- collects/mzlib/foreign.ss | 60 +++++++++----- collects/scribblings/foreign/derived.scrbl | 15 +++- collects/scribblings/foreign/types.scrbl | 96 ++++++++++++++++++---- collects/tests/mzscheme/foreign-test.c | 21 +++++ collects/tests/mzscheme/foreign-test.ss | 89 ++++++++++---------- 5 files changed, 196 insertions(+), 85 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index ba49128b32..4353030192 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -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) diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index d01425c895..2b64510041 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -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 diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 9594ceeb45..664a17b4c8 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -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 ::) diff --git a/collects/tests/mzscheme/foreign-test.c b/collects/tests/mzscheme/foreign-test.c index cb1dc07906..d0da456d43 100644 --- a/collects/tests/mzscheme/foreign-test.c +++ b/collects/tests/mzscheme/foreign-test.c @@ -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); } diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index e141bbd5b9..1cce9a4ba2 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -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; -} ------------------------------------------------------------------------------- |#