diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/foreign/pointers.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/foreign/pointers.scrbl index 0f0d4dbc53..ba680ff9e0 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/foreign/pointers.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/foreign/pointers.scrbl @@ -233,9 +233,9 @@ see @|InsideRacket|. ctype?) @#,elem{absent}] [cptr cpointer? @#,elem{absent}] - [mode (one-of/c 'nonatomic 'stubborn 'uncollectable - 'eternal 'interior 'atomic-interior - 'raw) + [mode (one-of/c 'raw 'atomic 'nonatomic + 'atomic-interior 'interior + 'stubborn 'uncollectable 'eternal) @#,elem{absent}] [fail-mode (one-of/c 'failok) @#,elem{absent}]) cpointer?]{ diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/foreign/types.scrbl index 1198a8da78..1f8ecd72c0 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/foreign/types.scrbl @@ -976,24 +976,37 @@ members.} @defproc[(_list-struct [#:alignment alignment (or/c #f 1 2 4 8 16) #f] + [#:malloc-mode malloc-mode + (one-of/c 'raw 'atomic 'nonatomic + 'atomic-interior 'interior + 'stubborn 'uncollectable 'eternal) + 'atomic] [type ctype?] ...+) ctype?]{ A type constructor that builds a struct type using @racket[make-cstruct-type] function and wraps it in a type that marshals a struct as a list of its components. Note that space for -structs must to be allocated; the converter for a +structs must to be allocated using @racket[malloc] with @racket[malloc-mode]; the converter for a @racket[_list-struct] type immediately allocates and uses a list from the allocated space, so it is inefficient. Use @racket[define-cstruct] -below for a more efficient approach.} +below for a more efficient approach. + +@history[#:changed "6.0.0.6" @elem{Added @racket[#:malloc-mode].}]} -@defform/subs[(define-cstruct id/sup ([field-id type-expr] ...) property ...) - [(id/sup _id - (_id _super-id)) - (property (code:line #:alignment alignment-expr) - (code:line #:property prop-expr val-expr) - #:no-equal)]]{ +@defform[(define-cstruct id/sup ([field-id type-expr] ...) property ...) + #:grammar [(id/sup _id + (_id _super-id)) + (property (code:line #:alignment alignment-expr) + (code:line #:malloc-mode malloc-mode-expr) + (code:line #:property prop-expr val-expr) + #:no-equal)] + #:contracts ([alignment-expr (or/c #f 1 2 4 8 16)] + [malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic + 'atomic-interior 'interior + 'stubborn 'uncollectable 'eternal)] + [prop-expr struct-type-property?])]{ Defines a new C struct type, but unlike @racket[_list-struct], the resulting type deals with C structs in binary form, rather than @@ -1001,8 +1014,8 @@ marshaling them to Racket values. The syntax is similar to @racket[define-struct], providing accessor functions for raw struct values (which are pointer objects); the @racket[_id] must start with @litchar{_}, and at most one @racket[#:alignment] -can be supplied. If no @racket[_super-id] is provided, then at least one -field must be specified. +or @racket[#:malloc-mode] can be supplied. If no @racket[_super-id] +is provided, then at least one field must be specified. The resulting bindings are as follows: @@ -1106,8 +1119,10 @@ arguments for each of @racketidfont{_}@racket[super-id]'s fields, in addition for the new fields. This adjustment of the constructor is, again, in analogy to using a supertype with @racket[define-struct]. -Structs are allocated as atomic blocks, which means that the -garbage collector ignores their content. Thus, struct fields can hold +Structs are allocated using @racket[malloc] with the result of +@racket[malloc-mode-expr], which default to @racket['atomic]. +The default allocation of @racket['atomic] means that the +garbage collector ignores the content of a struct; thus, struct fields can hold only non-pointer values, pointers to memory outside the GC's control, and otherwise-reachable pointers to immobile GC-managed values (such as those allocated with @racket[malloc] and @racket['internal] or @@ -1223,7 +1238,9 @@ expects arguments for both the super fields and the new ones: @racketblock[ (define-cstruct (#,(racketidfont "_B") #,(racketidfont "_A")) ([z _int])) (define b (make-B 1 2 3)) -]} +] + +@history[#:changed "6.0.0.6" @elem{Added @racket[#:malloc-mode].}]} @; ------------------------------------------------------------ diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index 780a2d4550..0f0c68443e 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -1317,7 +1317,9 @@ ;; Simple structs: call this with a list of types, and get a type that marshals ;; C structs to/from Scheme lists. -(define* (_list-struct #:alignment [alignment #f] type . types) +(define* (_list-struct #:alignment [alignment #f] + #:malloc-mode [malloc-mode 'atomic] + type . types) (let* ([types (cons type types)] [stype (make-cstruct-type types #f alignment)] [offsets (compute-offsets types alignment)] @@ -1331,7 +1333,7 @@ "expected length" len "list length" (length vals) "list" vals)) - (let ([block (malloc stype)]) + (let ([block (malloc stype malloc-mode)]) (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val)) types offsets vals) block)) @@ -1359,7 +1361,7 @@ (provide define-cstruct) (define-syntax (define-cstruct stx) (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx - alignment-stx property-stxes property-binding-stxes + alignment-stx malloc-mode-stx property-stxes property-binding-stxes no-equal?) (define name (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) @@ -1410,7 +1412,8 @@ [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))] [(offset ...) (generate-temporaries (ids (lambda (s) `(,s"-offset"))))] - [alignment alignment-stx]) + [alignment alignment-stx] + [malloc-mode (or malloc-mode-stx #'(quote atomic))]) (with-syntax ([get-super-info ;; the 1st-type might be a pointer to this type (if (or (safe-id=? 1st-type #'_TYPE-pointer/null) @@ -1524,7 +1527,7 @@ ;; init using all slots (lambda vals (if (= (length vals) (length all-types)) - (let ([block (make-wrap-TYPE (malloc _TYPE*))]) + (let ([block (make-wrap-TYPE (malloc _TYPE* malloc-mode))]) (set-cpointer-tag! block all-tags) (for-each (lambda (type ofs value) (ptr-set! block type 'abs ofs value)) @@ -1534,7 +1537,7 @@ (length all-types) (length vals) vals))) ;; normal initializer (lambda (slot ...) - (let ([block (make-wrap-TYPE (malloc _TYPE*))]) + (let ([block (make-wrap-TYPE (malloc _TYPE* malloc-mode))]) (set-cpointer-tag! block all-tags) (ptr-set! block stype 'abs offset slot) ... @@ -1545,7 +1548,7 @@ (cond [(TYPE? vals) vals] [(= (length vals) (length all-types)) - (let ([block (malloc _TYPE*)]) + (let ([block (malloc _TYPE* malloc-mode)]) (set-cpointer-tag! block all-tags) (for-each (lambda (type ofs value) @@ -1597,21 +1600,32 @@ (syntax-case #'type () [(t s) (values #'t #'s)] [_ (values #'type #f)])] - [(alignment properties property-bindings no-equal?) + [(alignment malloc-mode properties property-bindings no-equal?) (let loop ([more #'more] [alignment #f] + [malloc-mode #f] [properties null] [property-bindings null] [no-equal? #f]) (define (head) (syntax-case more () [(x . _) #'x])) (syntax-case more () - [() (values alignment (reverse properties) (reverse property-bindings) no-equal?)] + [() (values alignment + malloc-mode + (reverse properties) + (reverse property-bindings) + no-equal?)] [(#:alignment) (err "missing expression for #:alignment" (head))] [(#:alignment a . rest) (not alignment) - (loop #'rest #'a properties property-bindings no-equal?)] + (loop #'rest #'a malloc-mode properties property-bindings no-equal?)] [(#:alignment a . rest) (err "multiple specifications of #:alignment" (head))] + [(#:malloc-mode) (err "missing expression for #:malloc-mode" (head))] + [(#:malloc-mode m . rest) + (not malloc-mode) + (loop #'rest alignment #'m properties property-bindings no-equal?)] + [(#:alignment m . rest) + (err "multiple specifications of #:malloc-mode" (head))] [(#:property) (err "missing property expression for #:property" (head))] [(#:property prop) (err "missing value expression for #:property" (head))] [(#:property prop val . rest) @@ -1620,6 +1634,7 @@ (define val-id (car (generate-temporaries '(prop-val)))) (loop #'rest alignment + malloc-mode (list* #`(cons #,prop-id #,val-id) properties) (list* (list (list val-id) #'val) (list (list prop-id) #'(check-is-property prop)) @@ -1628,7 +1643,7 @@ [(#:no-equal . rest) (if no-equal? (err "multiple specifications of #:no-equal" (head)) - (loop #'rest alignment properties property-bindings #t))] + (loop #'rest alignment malloc-mode properties property-bindings #t))] [(x . _) (err (if (keyword? (syntax-e #'x)) "unknown keyword" "unexpected form") #'x)] @@ -1646,11 +1661,12 @@ #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) #`(#,_SUPER slot-type ...) alignment + malloc-mode properties property-bindings no-equal?) (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) - alignment properties property-bindings no-equal?)))] + alignment malloc-mode properties property-bindings no-equal?)))] [(_ type () . more) (identifier? #'type) (err "must have either a supertype or at least one field")]