From 6ac15688b2cb5bf98ba30cf42740ba862aa97085 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Sep 2010 16:27:29 -0600 Subject: [PATCH] add alignment option to ffi's cstruct support --- collects/ffi/unsafe.rkt | 23 +++++++++---- collects/scribblings/foreign/types.scrbl | 24 +++++++++---- src/foreign/foreign.c | 43 +++++++++++++++++++++--- src/foreign/foreign.rktc | 41 +++++++++++++++++++--- 4 files changed, 109 insertions(+), 22 deletions(-) diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 3f939313a7..f320bf8e08 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -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 diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 9728924274..612df43b29 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -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 diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 3a9f185c60..b283a0fd9b 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -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?", diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index aa48295471..fac59f5397 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -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; }