From 58371b95d4110f41eb92b6e2af8661577b65ba40 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Apr 2020 16:19:33 -0600 Subject: [PATCH] ffi/unsafe: add malloc-mode option to `_list` and `_vector` --- .../racket-doc/scribblings/foreign/misc.scrbl | 17 ++++- .../scribblings/foreign/types.scrbl | 24 ++++-- .../tests/racket/foreign-test.rktl | 6 +- racket/collects/ffi/unsafe.rkt | 75 ++++++++++++++----- 4 files changed, 88 insertions(+), 34 deletions(-) diff --git a/pkgs/racket-doc/scribblings/foreign/misc.scrbl b/pkgs/racket-doc/scribblings/foreign/misc.scrbl index 8a1e2d8623..d0fcc633a6 100644 --- a/pkgs/racket-doc/scribblings/foreign/misc.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/misc.scrbl @@ -5,7 +5,8 @@ @defproc[(list->cblock [lst list?] [type ctype?] - [expect-length (or/c exact-nonnegative-integer? #f) #f]) + [expect-length (or/c exact-nonnegative-integer? #f) #f] + [#:malloc-mode malloc-mode (or/c #f symbol?) #f]) cpointer?]{ Allocates a memory block of an appropriate size---using @@ -16,16 +17,24 @@ according to the given @racket[type]. If @racket[expect-length] is not @racket[#f] and not the same as @racket[(length lst)], then an exception is raised instead of -allocating memory.} +allocating memory. + +If @racket[malloc-mode] is not @racket[#f], it is provided as an +additional argument to @racket[malloc]. + +@history[#:changed "7.7.0.2" @elem{Added the @racket[#:malloc-mode] argument.}]} @defproc[(vector->cblock [vec vector?] [type ctype?] - [expect-length (or/c exact-nonnegative-integer? #f) #f]) + [expect-length (or/c exact-nonnegative-integer? #f) #f] + [#:malloc-mode malloc-mode (or/c #f symbol?) #f]) cpointer?]{ Like @racket[list->cblock], but using values from a vector instead of -a list.} +a list. + +@history[#:changed "7.7.0.2" @elem{Added the @racket[#:malloc-mode] argument.}]} @defproc[(vector->cpointer [vec vector?]) cpointer?]{ diff --git a/pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-doc/scribblings/foreign/types.scrbl index e84b4a3555..5e671355f0 100644 --- a/pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/types.scrbl @@ -1077,10 +1077,18 @@ Example: -> (values res (unbox boxed))) ]} -@defform/subs[(_list mode type maybe-len) +@defform/subs[#:literals (atomic raw atomic nonatomic tagged + atomic-interior interior + stubborn uncollectable eternal) + (_list mode type maybe-len maybe-mode) ([mode i o io] [maybe-len code:blank - len-expr])]{ + len-expr] + [maybe-mode code:blank + atomic + raw atomic nonatomic tagged + atomic-interior interior + stubborn uncollectable eternal])]{ A @tech{custom function type} that is similar to @racket[_ptr], except that it is used for converting lists to/from C vectors. The optional @@ -1089,6 +1097,8 @@ the post code, and in the pre code of an output mode to allocate the block. (If the length is 0, then NULL is passed in and an empty list is returned.) In either case, it can refer to a previous binding for the length of the list which the C function will most likely require. +The @racket[maybe-mode], if provided, is quoted and passed to @racket[malloc] +as needed to allocate the C representation. For example, the following type corresponds to a function that takes a vector argument of type @tt{*float} (from a Racket list input) @@ -1112,9 +1122,11 @@ return two values, the vector and the boolean. [vec : (_list o _float len)] -> [res : _bool] -> (values vec res)) -]} +] -@defform[(_vector mode type maybe-len)]{ +@history[#:changed "7.7.0.2" @elem{Added @racket[maybe-mode].}]} + +@defform[(_vector mode type maybe-len maybe-mode)]{ A @tech{custom function type} like @racket[_list], except that it uses Racket vectors instead of lists. @@ -1131,7 +1143,9 @@ Examples: -> (values vec res)) ] -See @racket[_list] for more explanation about the examples.} +See @racket[_list] for more explanation about the examples. + +@history[#:changed "7.7.0.2" @elem{Added @racket[maybe-mode].}]} @defform*[#:id _bytes diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index d5818f091f..830d947be1 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/pkgs/racket-test-core/tests/racket/foreign-test.rktl @@ -287,12 +287,8 @@ ((ffi 'hoho (_fun _int (_fun _int -> (_fun _int -> _int)) -> _int)) 3 (lambda (x) (lambda (y) (+ y (* x x)))))) ;; --- - ;; FIXME: this test is broken, because the array allocated by `(_list io _int len)` - ;; has no reason to stay in place; a GC during the callback may move it. - ;; The solution is probably to extend `_list` so that an allocation mode like - ;; 'atomic-interior can be supplied. (let ([qsort (get-ffi-obj 'qsort #f - (_fun (l : (_list io _int len)) + (_fun (l : (_list io _int len atomic-interior)) (len : _int = (length l)) (size : _int = (ctype-sizeof _int)) (compare : (_fun _pointer _pointer -> _int)) diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index 4646c90748..7c44a712dc 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -1091,28 +1091,57 @@ (provide _list) (define-fun-syntax _list (syntax-rules (i o io) - [(_ i t ) (type: _pointer - pre: (x => (list->cblock x t)))] - [(_ o t n) (type: _pointer - pre: (malloc n t) - post: (x => (cblock->list x t n)))] - [(_ io t n) (type: _pointer - pre: (x => (list->cblock x t)) - post: (x => (cblock->list x t n)))])) + [(_ i t ) (type: _pointer + pre: (x => (list->cblock x t)))] + [(_ i t mode) (type: _pointer + pre: (x => (list->cblock x t #:malloc-mode (check-malloc-mode _list mode))))] + [(_ o t n) (type: _pointer + pre: (malloc n t) + post: (x => (cblock->list x t n)))] + [(_ o t n mode) (type: _pointer + pre: (malloc n t (check-malloc-mode _list mode)) + post: (x => (cblock->list x t n)))] + [(_ io t n) (type: _pointer + pre: (x => (list->cblock x t)) + post: (x => (cblock->list x t n)))] + [(_ io t n mode) (type: _pointer + pre: (x => (list->cblock x t #:malloc-mode (check-malloc-mode _list mode))) + post: (x => (cblock->list x t n)))])) ;; (_vector []) ;; Same as _list, except that it uses Scheme vectors. (provide _vector) (define-fun-syntax _vector (syntax-rules (i o io) - [(_ i t ) (type: _pointer - pre: (x => (vector->cblock x t)))] - [(_ o t n) (type: _pointer - pre: (malloc n t) - post: (x => (cblock->vector x t n)))] - [(_ io t n) (type: _pointer - pre: (x => (vector->cblock x t)) - post: (x => (cblock->vector x t n)))])) + [(_ i t ) (type: _pointer + pre: (x => (vector->cblock x t)))] + [(_ i t mode) (type: _pointer + pre: (x => (vector->cblock x t #:malloc-mode (check-malloc-mode _vector mode))))] + [(_ o t n) (type: _pointer + pre: (malloc n t) + post: (x => (cblock->vector x t n)))] + [(_ o t n mode) (type: _pointer + pre: (malloc n t (check-malloc-mode _vector mode)) + post: (x => (cblock->vector x t n)))] + [(_ io t n) (type: _pointer + pre: (x => (vector->cblock x t)) + post: (x => (cblock->vector x t n)))] + [(_ io t n mode) (type: _pointer + pre: (x => (vector->cblock x t #:malloc-mode (check-malloc-mode _vector mode))) + post: (x => (cblock->vector x t n)))])) + +(define-syntax (check-malloc-mode stx) + (syntax-case stx () + [(_ _ mode) + (memq (syntax-e #'mode) + '(raw atomic nonatomic tagged + atomic-interior interior + stubborn uncollectable eternal)) + #'(quote mode)] + [(_ who mode) + (raise-syntax-error (syntax-e #'who) + "invalid malloc mode" + #'mode)])) ;; Reflect the difference between 'racket and 'chez-scheme ;; VMs for `_bytes` in `_bytes*`: @@ -2026,14 +2055,17 @@ (values x type)))) ;; Converting Scheme lists to/from C vectors (going back requires a length) -(define* (list->cblock l type [need-len #f]) +(define* (list->cblock l type [need-len #f] + #:malloc-mode [mode #f]) (define len (length l)) (when need-len (unless (= len need-len) (error 'list->cblock "list does not have the expected length: ~e" l))) (if (null? l) #f ; null => NULL - (let ([cblock (malloc len type)]) + (let ([cblock (if mode + (malloc len type mode) + (malloc len type))]) (let loop ([l l] [i 0]) (unless (null? l) (ptr-set! cblock type i (car l)) @@ -2051,14 +2083,17 @@ "expecting a non-void pointer, got ~s" cblock)])) ;; Converting Scheme vectors to/from C vectors -(define* (vector->cblock v type [need-len #f]) +(define* (vector->cblock v type [need-len #f] + #:malloc-mode [mode #f]) (let ([len (vector-length v)]) (when need-len (unless (= need-len len) (error 'vector->cblock "vector does not have the expected length: ~e" v))) (if (zero? len) #f ; #() => NULL - (let ([cblock (malloc len type)]) + (let ([cblock (if mode + (malloc len type mode) + (malloc len type))]) (let loop ([i 0]) (when (< i len) (ptr-set! cblock type i (vector-ref v i))