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

change _fpointer handling to work with function pointers in structs and other such uses; add 'function-ptr' casting operation

Browse Source 
svn: r12913
This commit is contained in:
Matthew Flatt 2008-12-20 05:09:35 +00:00
parent a62b6a3128
commit 82ead03b92
6 changed files with 81 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/ffi/objc.ss
View File

@ -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)))

9
collects/mzlib/foreign.ss
View File

@ -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

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

@ -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}

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

@ -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)))))

55
src/foreign/foreign.c
View File

@ -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; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
avalues = NULL;
switch (CTYPE_PRIMLABEL(base)) {
case FOREIGN_fpointer: /* need to allocate a pointer */
p = scheme_make_foreign_cpointer(oval.x_pointer);
break;
case FOREIGN_struct:
memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
free(p);

52
src/foreign/foreign.ssc
View File

@ -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; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
avalues = NULL;
switch (CTYPE_PRIMLABEL(base)) {
case FOREIGN_fpointer: /* need to allocate a pointer */
p = scheme_make_foreign_cpointer(oval.x_pointer);
break;
case FOREIGN_struct:
memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
free(p);