From 82ead03b92f7288fede1aaf6679312fc5d2093f2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 20 Dec 2008 05:09:35 +0000 Subject: [PATCH] change _fpointer handling to work with function pointers in structs and other such uses; add 'function-ptr' casting operation svn: r12913 --- collects/ffi/objc.ss | 15 ++++--- collects/mzlib/foreign.ss | 9 +++- collects/scribblings/foreign/types.scrbl | 21 +++++---- collects/tests/mzscheme/foreign-test.ss | 8 +++- src/foreign/foreign.c | 55 +++++++++++------------- src/foreign/foreign.ssc | 52 ++++++++++------------ 6 files changed, 81 insertions(+), 79 deletions(-) diff --git a/collects/ffi/objc.ss b/collects/ffi/objc.ss index 37e67c5092..8c9be4ccb9 100644 --- a/collects/ffi/objc.ss +++ b/collects/ffi/objc.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require scheme/foreign (only-in '#%foreign ffi-call) +(require scheme/foreign scheme/stxparam (for-syntax scheme/base)) (unsafe!) @@ -73,12 +73,13 @@ (define (lookup-send types msgSends msgSend msgSend_fpret first-arg-type) ;; First type in `types' vector is the result type (or (hash-ref msgSends types #f) - (let ([m (ffi-call (if (memq (ctype->layout (vector-ref types 0)) - '(float double double*)) - msgSend_fpret - msgSend) - (list* first-arg-type _SEL (cdr (vector->list types))) - (vector-ref types 0))]) + (let ([m (function-ptr (if (memq (ctype->layout (vector-ref types 0)) + '(float double double*)) + msgSend_fpret + msgSend) + (_cprocedure + (list* first-arg-type _SEL (cdr (vector->list types))) + (vector-ref types 0)))]) (hash-set! msgSends types m) m))) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index a01579b35f..42a9103364 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -62,7 +62,7 @@ _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 _fixint _ufixint _fixnum _ufixnum _float _double _double* - _bool _pointer _scheme _fpointer + _bool _pointer _scheme _fpointer function-ptr (unsafe memcpy) (unsafe memmove) (unsafe memset) (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) @@ -676,6 +676,13 @@ (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) +(define (function-ptr p fun-ctype) + (if (cpointer? p) + (if (eq? (ctype->layout fun-ctype) 'fpointer) + ((ctype-c->scheme fun-ctype) p) + (raise-type-error 'function-ptr "function ctype" fun-ctype)) + (raise-type-error 'function-ptr "cpointer" p))) + ;; ---------------------------------------------------------------------------- ;; String types diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index b2d83ec418..595968b27e 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -279,15 +279,14 @@ PLT Scheme's C API.} @defthing[_fpointer ctype?]{ -Similar to @scheme[_pointer], except that it should be used with -function pointers. Using these pointers avoids one dereferencing, -which is the proper way of dealing with function pointers. This type -should be used only in rare situations where you need to pass a -foreign function pointer to a foreign function; using a -@scheme[_cprocedure] type is possible for such situations, but -inefficient, as every call will go through Scheme unnecessarily. -Otherwise, @scheme[_cprocedure] should be used (it is based on -@scheme[_fpointer]).} +Similar to @scheme[_pointer], except that when an @scheme[_fpointer] +is extracted from a pointer produced by @scheme[ffi-obj-ref], then a +level of indirection is skipped. A level of indirection is similarly +skipped when extracting a pointer via @scheme[get-ffi-obj]. + +A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer], +and normally @scheme[_cprocedure] should be used instead of +@scheme[_fpointer].} @; ------------------------------------------------------------ @@ -440,6 +439,10 @@ For example, specifies a function that receives an integer and a string, but the foreign function receives the string first.} +@defproc[(function-ptr [ptr cpointer?] [fun-type ctype?]) cpointer?]{ + +Casts @scheme[ptr] to a function pointer of type @scheme[fun-type].} + @; ---------------------------------------------------------------------- @subsection[#:tag "foreign:custom-types"]{Custom Function Types} diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index bb624d4ddb..c55ab2c358 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -101,9 +101,15 @@ (test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int)) (lambda (p) ((p (ffi 'add1_byte_byte (_fun _byte -> _byte)) 3) 10))) ;; --- + (test* 4 'g2 _int (lambda (p) p)) + ;; --- (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))) + (test* 4 'g3 _pointer (lambda (p) ((function-ptr p (_fun _int -> _int)) 3))) + ;; Equivalentlly, 'g3 is a static variable that holds a function pointer. By + ;; looking it up with _fpointer, we get its address, which then works + ;; with ptr-ref to extract the function. + (test* 7 'g3 _fpointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 6))) ;; --- (test ((lambda (x f) ((f (+ x 1)) (- x 1))) 3 (lambda (x) (lambda (y) (+ y (* x x))))) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index f29da13eb9..6d927005b6 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -805,7 +805,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_fpointer (27) /* Type Name: fpointer * LibFfi type: ffi_type_pointer - * C type: -none- + * C type: void* * Predicate: -none- * Scheme->C: -none- * S->C offset: 0 @@ -838,6 +838,7 @@ typedef union _ForeignAny { char* x_symbol; void* x_pointer; Scheme_Object* x_scheme; + void* x_fpointer; } ForeignAny; /* This is a tag that is used to identify user-made struct types. */ @@ -970,7 +971,7 @@ static int ctype_sizeof(Scheme_Object *type) case FOREIGN_symbol: return sizeof(char*); case FOREIGN_pointer: return sizeof(void*); case FOREIGN_scheme: return sizeof(Scheme_Object*); - case FOREIGN_fpointer: return 0; + case FOREIGN_fpointer: return sizeof(void*); /* for structs */ default: return CTYPE_PRIMTYPE(type)->size; } @@ -1219,8 +1220,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, else return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res)); } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - /* No need for the REF_CTYPE trick for pointers */ - return (Scheme_Object*)W_OFFSET(src, delta); + return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta)); } else switch (CTYPE_PRIMLABEL(type)) { case FOREIGN_void: return scheme_void; case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8)); @@ -1248,7 +1248,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*)); case FOREIGN_pointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*)); case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*); - case FOREIGN_fpointer: return scheme_void; + case FOREIGN_fpointer: return (REF_CTYPE(void*)); case FOREIGN_struct: return scheme_make_foreign_cpointer(W_OFFSET(src, delta)); default: scheme_signal_error("corrupt foreign type: %V", type); @@ -1280,7 +1280,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, type = CTYPE_BASETYPE(type); } if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - /* No need for the SET_CTYPE trick for pointers */ + /* No need for the SET_CTYPE trick for pointers. */ if (SCHEME_FFICALLBACKP(val)) ((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback; else if (SCHEME_CPTRP(val)) @@ -2202,19 +2202,24 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); - else size = ctype_sizeof(base); + size = ctype_sizeof(base); + if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (argc > 2) - scheme_signal_error - (MYNAME": referencing fpointer with extra arguments"); - else + if (SCHEME_FFIOBJP(argv[0])) { + /* The ffiobj pointer is the function pointer. */ ptr = argv[0]; - } else if (size < 0) { + delta = (long)&(((ffi_obj_struct*)0x0)->obj); + } + } + + if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv); - } else if (argc > 3) { + } + + if (argc > 3) { if (!SAME_OBJ(argv[2],abs_sym)) scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv); if (!SCHEME_INTP(argv[3])) @@ -2223,6 +2228,8 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) } else if (argc > 2) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); + if (!size) + scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } return C2SCHEME(argv[1], ptr, delta, 0); @@ -2248,22 +2255,9 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[]) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); - else size = ctype_sizeof(base); + size = ctype_sizeof(base); - if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (SCHEME_CPTRP(argv[0])) { - /* offset is ok */ - } else if SCHEME_FFIOBJP(argv[0]) { - if (argc > 3) { - scheme_signal_error - (MYNAME": cannot set fpointer value with offset"); - } - ptr = ((ffi_obj_struct*)(argv[0]))->obj; - } else { - scheme_signal_error - (MYNAME": bad lvalue (NULL or string)"); - } - } else if (size < 0) { + if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { @@ -2279,6 +2273,8 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[]) } else if (argc > 3) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); + if (!size) + scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0); @@ -2475,9 +2471,6 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) for (i=0; isize); free(p); diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index c83fd900ff..50e2f77854 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -743,7 +743,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) (~ "/* Special type, not actually used for anything except to mark values" \\ " * that are treated like pointers but not referenced. Used for" \\ " * creating function types. */") -(defctype 'fpointer 'ftype "pointer" 'ctype #f) +(defctype 'fpointer 'ftype "pointer" 'ctype "void*") :} typedef union _ForeignAny { @@ -1022,8 +1022,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, else return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res)); } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - /* No need for the REF_CTYPE trick for pointers */ - return (Scheme_Object*)W_OFFSET(src, delta); + return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta)); } else switch (CTYPE_PRIMLABEL(type)) { {:(for-each-type (~ "case FOREIGN_"cname": return " @@ -1062,7 +1061,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, type = CTYPE_BASETYPE(type); } if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - /* No need for the SET_CTYPE trick for pointers */ + /* No need for the SET_CTYPE trick for pointers. */ if (SCHEME_FFICALLBACKP(val)) ((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback; else if (SCHEME_CPTRP(val)) @@ -1076,7 +1075,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (define (wrong-type obj type) (list "scheme_wrong_type(\"Scheme->C\",\""type"\",0,1,&("obj"));")) (~ "case FOREIGN_"cname":") - (if ctype + (if (and ctype (not (equal? stype "fpointer"))) (let* ([x (list "((("ctype"*)W_OFFSET(dst,delta))[0])")] [f (lambda (p) (if (procedure? p) (p "val" x) (list p"(val)")))]) @@ -1600,19 +1599,24 @@ static Scheme_Object *do_memop(const char *who, int mode, scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); - else size = ctype_sizeof(base); + size = ctype_sizeof(base); + if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (argc > 2) - scheme_signal_error - (MYNAME": referencing fpointer with extra arguments"); - else + if (SCHEME_FFIOBJP(argv[0])) { + /* The ffiobj pointer is the function pointer. */ ptr = argv[0]; - } else if (size < 0) { + delta = (long)&(((ffi_obj_struct*)0x0)->obj); + } + } + + if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv); - } else if (argc > 3) { + } + + if (argc > 3) { if (!SAME_OBJ(argv[2],abs_sym)) scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv); if (!SCHEME_INTP(argv[3])) @@ -1621,6 +1625,8 @@ static Scheme_Object *do_memop(const char *who, int mode, } else if (argc > 2) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); + if (!size) + scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } return C2SCHEME(argv[1], ptr, delta, 0); @@ -1644,22 +1650,9 @@ static Scheme_Object *do_memop(const char *who, int mode, scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); - else size = ctype_sizeof(base); + size = ctype_sizeof(base); - if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (SCHEME_CPTRP(argv[0])) { - /* offset is ok */ - } else if SCHEME_FFIOBJP(argv[0]) { - if (argc > 3) { - scheme_signal_error - (MYNAME": cannot set fpointer value with offset"); - } - ptr = ((ffi_obj_struct*)(argv[0]))->obj; - } else { - scheme_signal_error - (MYNAME": bad lvalue (NULL or string)"); - } - } else if (size < 0) { + if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { @@ -1675,6 +1668,8 @@ static Scheme_Object *do_memop(const char *who, int mode, } else if (argc > 3) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); + if (!size) + scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0); @@ -1867,9 +1862,6 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) for (i=0; isize); free(p);