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

add alignment option to ffi's cstruct support

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-09 16:27:29 -06:00
parent 00264b9cbc
commit 6ac15688b2
4 changed files with 109 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/ffi/unsafe.rkt
View File

@ -1143,8 +1143,8 @@
;; 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)]
(define* (_list-struct #:alignment [alignment 2] . types)
(let ([stype (make-cstruct-type types #f alignment)]
[offsets (compute-offsets types)]
[len (length types)])
(make-ctype stype
@ -1178,7 +1178,7 @@
;; type.
(provide define-cstruct)
(define-syntax (define-cstruct stx)
(define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx)
(define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx alignment-stx)
(define name
(cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
(define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
@ -1220,7 +1220,8 @@
[(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))]
[(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
[(offset ...) (generate-temporaries
(ids (lambda (s) `(,s"-offset"))))])
(ids (lambda (s) `(,s"-offset"))))]
[alignment alignment-stx])
(with-syntax ([get-super-info
;; the 1st-type might be a pointer to this type
(if (or (safe-id=? 1st-type #'_TYPE-pointer/null)
@ -1255,7 +1256,7 @@
(define all-tags (cons TYPE-tag super-tags))
(define _TYPE*
;; c->scheme adjusts all tags
(let* ([cst (make-cstruct-type types)]
(let* ([cst (make-cstruct-type types #f alignment)]
[t (_cpointer TYPE-tag cst)]
[c->s (ctype-c->scheme t)])
(make-ctype cst (ctype-scheme->c t)
@ -1352,11 +1353,19 @@
[(_ _TYPE ([slot slot-type] ...))
(and (_-identifier? #'_TYPE stx)
(identifiers? #'(slot ...)))
(make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))]
(make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'#f)]
[(_ _TYPE #:alignment alignment-expr ([slot slot-type] ...))
(and (_-identifier? #'_TYPE stx)
(identifiers? #'(slot ...)))
(make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'alignment-expr)]
[(_ (_TYPE _SUPER) ([slot slot-type] ...))
(and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...)))
(with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
(make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))]))
(make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'#f))]
[(_ (_TYPE _SUPER) #:alignment alignment-expr ([slot slot-type] ...))
(and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...)))
(with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
(make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'alignment-expr))]))
;; helper for the above: keep runtime information on structs
(define cstruct-info

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

@ -343,7 +343,7 @@ the later case, the result is the @scheme[ctype]).}
@defproc[(_cprocedure [input-types (list ctype?)]
[output-type ctype?]
[#:abi abi (or/c symbol/c #f) #f]
[#:abi abi (or/c #f 'default 'stdcall 'sysv) #f]
[#:atomic? atomic? any/c #f]
[#:async-apply async-apply (or/c #f ((-> any) . -> . any)) #f]
[#:save-errno save-errno (or/c #f 'posix 'windows) #f]
@ -744,7 +744,10 @@ is present for consistency with the above macros).}
@section{C Struct Types}
@defproc[(make-cstruct-type [types (listof ctype?)]) ctype?]{
@defproc[(make-cstruct-type [types (listof ctype?)]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[alignment (or/c #f 1 2 4 8 16) #f])
ctype?]{
The primitive type constructor for creating new C struct types. These
types are actually new primitive types; they have no conversion
@ -752,10 +755,17 @@ functions associated. The corresponding Racket objects that are used
for structs are pointers, but when these types are used, the value
that the pointer @italic{refers to} is used, rather than the pointer
itself. This value is basically made of a number of bytes that is
known according to the given list of @scheme[types] list.}
known according to the given list of @scheme[types] list.
If @racket[alignment] is @racket[#f], then the natural alignment of
each type in @racket[types] is used for its alignment within the
struct type. Otherwise, @racket[alignment] is used for all struct type
members.}
@defproc[(_list-struct [type ctype?] ...+) ctype?]{
@defproc[(_list-struct [#:alignment alignment (or/c #f 1 2 4 8 16) #f]
[type ctype?] ...+)
ctype?]{
A type constructor that builds a struct type using
@scheme[make-cstruct-type] function and wraps it in a type that
@ -766,9 +776,11 @@ the allocated space, so it is inefficient. Use @scheme[define-cstruct]
below for a more efficient approach.}
@defform/subs[(define-cstruct id/sup ([field-id type-expr] ...))
@defform/subs[(define-cstruct id/sup alignment ([field-id type-expr] ...))
[(id/sup _id
(_id super-id))]]{
(_id super-id))
(alignment code:blank
(code:line #:alignment alignment-expr))]]{
Defines a new C struct type, but unlike @scheme[_list-struct], the
resulting type deals with C structs in binary form, rather than

43
src/foreign/foreign.c
View File

@ -1013,6 +1013,16 @@ void free_libffi_type(void *ignored, void *p)
free(p);
}
void free_libffi_type_with_alignment(void *ignored, void *p)
{
int i;
for (i = 0; ((ffi_type*)p)->elements[i]; i++) {
free(((ffi_type*)p)->elements[i]);
}
free_libffi_type(ignored, p);
}
/*****************************************************************************/
/* ABI spec */
@ -1049,7 +1059,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
/*****************************************************************************/
/* cstruct types */
/* (make-cstruct-type types [abi]) -> ctype */
/* (make-cstruct-type types [abi alignment]) -> ctype */
/* This creates a new primitive type that is a struct. This type can be used
* with cpointer objects, except that the contents is used rather than the
* pointer value. Marshaling to lists or whatever should be done in Scheme. */
@ -1063,11 +1073,24 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
GC_CAN_IGNORE ffi_type **elements, *libffi_type, **dummy;
ctype_struct *type;
ffi_cif cif;
int i, nargs;
int i, nargs, with_alignment;
ffi_abi abi;
nargs = scheme_proper_list_length(argv[0]);
if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv);
abi = GET_ABI(MYNAME,1);
if (argc > 2) {
if (!SCHEME_FALSEP(argv[2])) {
if (!SAME_OBJ(argv[2], scheme_make_integer(1))
&& !SAME_OBJ(argv[2], scheme_make_integer(2))
&& !SAME_OBJ(argv[2], scheme_make_integer(4))
&& !SAME_OBJ(argv[2], scheme_make_integer(8))
&& !SAME_OBJ(argv[2], scheme_make_integer(16)))
scheme_wrong_type(MYNAME, "1, 2, 4, 8, 16, or #f", 2, argc, argv);
with_alignment = SCHEME_INT_VAL(argv[2]);
} else
with_alignment = 0;
} else
with_alignment = 0;
/* allocate the type elements */
elements = malloc((nargs+1) * sizeof(ffi_type*));
elements[nargs] = NULL;
@ -1077,6 +1100,13 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 0, argc, argv);
elements[i] = CTYPE_PRIMTYPE(base);
if (with_alignment) {
/* copy the type to set an alignment: */
libffi_type = malloc(sizeof(ffi_type));
memcpy(libffi_type, elements[i], sizeof(ffi_type));
elements[i] = libffi_type;
elements[i]->alignment = with_alignment;
}
}
/* allocate the new libffi type object */
libffi_type = malloc(sizeof(ffi_type));
@ -1093,7 +1123,10 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
type->basetype = (argv[0]);
type->scheme_to_c = ((Scheme_Object*)libffi_type);
type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
if (with_alignment)
scheme_register_finalizer(type, free_libffi_type_with_alignment, libffi_type, NULL, NULL);
else
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
return (Scheme_Object*)type;
}
#undef MYNAME
@ -3089,7 +3122,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global("make-ctype",
scheme_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv);
scheme_add_global("make-cstruct-type",
scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 2), menv);
scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 3), menv);
scheme_add_global("ffi-callback?",
scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv);
scheme_add_global("cpointer?",
@ -3387,7 +3420,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global("make-ctype",
scheme_make_prim_w_arity((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), menv);
scheme_add_global("make-cstruct-type",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 2), menv);
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), menv);
scheme_add_global("ffi-callback?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), menv);
scheme_add_global("cpointer?",

41
src/foreign/foreign.rktc
View File

@ -853,6 +853,16 @@ void free_libffi_type(void *ignored, void *p)
free(p);
}
void free_libffi_type_with_alignment(void *ignored, void *p)
{
int i;
for (i = 0; ((ffi_type*)p)->elements[i]; i++) {
free(((ffi_type*)p)->elements[i]);
}
free_libffi_type(ignored, p);
}
/*****************************************************************************/
/* ABI spec */
@ -887,11 +897,11 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
/*****************************************************************************/
/* cstruct types */
/* (make-cstruct-type types [abi]) -> ctype */
/* (make-cstruct-type types [abi alignment]) -> ctype */
/* This creates a new primitive type that is a struct. This type can be used
* with cpointer objects, except that the contents is used rather than the
* pointer value. Marshaling to lists or whatever should be done in Scheme. */
@cdefine[make-cstruct-type 1 2]{
@cdefine[make-cstruct-type 1 3]{
Scheme_Object *p, *base;
/* since ffi_type objects can be used in callbacks, they are allocated using
* malloc so they don't move, and they are freed when the Scheme object is
@ -899,11 +909,24 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
GC_CAN_IGNORE ffi_type **elements, *libffi_type, **dummy;
ctype_struct *type;
ffi_cif cif;
int i, nargs;
int i, nargs, with_alignment;
ffi_abi abi;
nargs = scheme_proper_list_length(argv[0]);
if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv);
abi = GET_ABI(MYNAME,1);
if (argc > 2) {
if (!SCHEME_FALSEP(argv[2])) {
if (!SAME_OBJ(argv[2], scheme_make_integer(1))
&& !SAME_OBJ(argv[2], scheme_make_integer(2))
&& !SAME_OBJ(argv[2], scheme_make_integer(4))
&& !SAME_OBJ(argv[2], scheme_make_integer(8))
&& !SAME_OBJ(argv[2], scheme_make_integer(16)))
scheme_wrong_type(MYNAME, "1, 2, 4, 8, 16, or #f", 2, argc, argv);
with_alignment = SCHEME_INT_VAL(argv[2]);
} else
with_alignment = 0;
} else
with_alignment = 0;
/* allocate the type elements */
elements = malloc((nargs+1) * sizeof(ffi_type*));
elements[nargs] = NULL;
@ -913,6 +936,13 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 0, argc, argv);
elements[i] = CTYPE_PRIMTYPE(base);
if (with_alignment) {
/* copy the type to set an alignment: */
libffi_type = malloc(sizeof(ffi_type));
memcpy(libffi_type, elements[i], sizeof(ffi_type));
elements[i] = libffi_type;
elements[i]->alignment = with_alignment;
}
}
/* allocate the new libffi type object */
libffi_type = malloc(sizeof(ffi_type));
@ -927,7 +957,10 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
@cmake["type" ctype "argv[0]"
"(Scheme_Object*)libffi_type"
"(Scheme_Object*)FOREIGN_struct"]
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
if (with_alignment)
scheme_register_finalizer(type, free_libffi_type_with_alignment, libffi_type, NULL, NULL);
else
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
return (Scheme_Object*)type;
}