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

Improve define-cstruct inline-ability and add #:define-unsafe

Browse Source
This commit is contained in:
Jay McCarthy 2016-01-06 16:52:53 -05:00
parent 69b01c637f
commit 18208f76f5
3 changed files with 222 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "6.3.0.12") (define version "6.3.0.13")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

15
pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -1081,7 +1081,8 @@ below for a more efficient approach.
(property (code:line #:alignment alignment-expr) (property (code:line #:alignment alignment-expr)
(code:line #:malloc-mode malloc-mode-expr) (code:line #:malloc-mode malloc-mode-expr)
(code:line #:property prop-expr val-expr) (code:line #:property prop-expr val-expr)
#:no-equal)] #:no-equal
#:define-unsafe)]
#:contracts ([offset-expr exact-integer?] #:contracts ([offset-expr exact-integer?]
[alignment-expr (or/c #f 1 2 4 8 16)] [alignment-expr (or/c #f 1 2 4 8 16)]
[malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic [malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic
@ -1130,6 +1131,15 @@ The resulting bindings are as follows:
@item{@racketidfont{set-}@racketvarfont{id}@racketidfont{-}@racket[field-id]@racketidfont{!} @item{@racketidfont{set-}@racketvarfont{id}@racketidfont{-}@racket[field-id]@racketidfont{!}
: a mutator function for each @racket[field-id].} : a mutator function for each @racket[field-id].}
@item{@racketvarfont{id}@racketidfont{-}@racket[field-id]@racketidfont{-offset}
: the absolute offset, in bytes, of each @racket[field-id], if @racket[#:define-unsafe] is present.}
@item{@racketidfont{unsafe-}@racketvarfont{id}@racketidfont{-}@racket[field-id]
: an unsafe accessor function for each @racket[field-id], if @racket[#:define-unsafe] is present.}
@item{@racketidfont{unsafe-set-}@racketvarfont{id}@racketidfont{-}@racket[field-id]@racketidfont{!}
: an unsafe mutator function for each @racket[field-id], if @racket[#:define-unsafe] is present.}
@item{@racketvarfont{id}: structure-type information compatible with @item{@racketvarfont{id}: structure-type information compatible with
@racket[struct-out] or @racket[match] (but not @racket[struct] or @racket[struct-out] or @racket[match] (but not @racket[struct] or
@racket[define-struct]); @racket[define-struct]);
@ -1328,7 +1338,8 @@ expects arguments for both the super fields and the new ones:
] ]
@history[#:changed "6.0.0.6" @elem{Added @racket[#:malloc-mode].} @history[#:changed "6.0.0.6" @elem{Added @racket[#:malloc-mode].}
#:changed "6.1.1.8" @elem{Added @racket[#:offset] for fields.}]} #:changed "6.1.1.8" @elem{Added @racket[#:offset] for fields.}
#:changed "6.3.0.13" @elem{Added @racket[#:define-unsafe].}]}
@; ------------------------------------------------------------ @; ------------------------------------------------------------

181
racket/collects/ffi/unsafe.rkt
View File

@ -2,7 +2,7 @@
;; Foreign Racket interface ;; Foreign Racket interface
(require '#%foreign setup/dirs racket/unsafe/ops racket/private/for (require '#%foreign setup/dirs racket/unsafe/ops racket/private/for
(for-syntax racket/base racket/list syntax/stx (for-syntax racket/base racket/list syntax/stx racket/syntax
racket/struct-info)) racket/struct-info))
(provide ctype-sizeof ctype-alignof compiler-sizeof (provide ctype-sizeof ctype-alignof compiler-sizeof
@ -1348,15 +1348,16 @@
[TYPE? (id name "?")] [TYPE? (id name "?")]
[TYPE-tag (id name "-tag")] [TYPE-tag (id name "-tag")]
[_TYPE/null (id "_" name "/null")]) [_TYPE/null (id "_" name "/null")])
#'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag) #'(begin
(let ([TYPE-tag 'TYPE]) (define TYPE-tag
(gensym 'TYPE))
(define _TYPE
(_cpointer TYPE-tag ptr-type scheme->c c->scheme))
(define _TYPE/null
(_cpointer/null TYPE-tag ptr-type scheme->c c->scheme))
;; Make the predicate function have the right inferred name ;; Make the predicate function have the right inferred name
(define (TYPE? x) (define (TYPE? x)
(and (cpointer? x) (cpointer-has-tag? x TYPE-tag))) (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))))))]))
(values (_cpointer TYPE-tag ptr-type scheme->c c->scheme)
(_cpointer/null TYPE-tag ptr-type scheme->c c->scheme)
TYPE?
TYPE-tag)))))]))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; Struct wrappers ;; Struct wrappers
@ -1423,9 +1424,14 @@
;; type. ;; type.
(provide define-cstruct) (provide define-cstruct)
(define-syntax (define-cstruct stx) (define-syntax (define-cstruct stx)
(define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx slot-offsets-stx (define (make-syntax
_TYPE-stx has-super? slot-names-stx slot-types-stx slot-offsets-stx
alignment-stx malloc-mode-stx property-stxes property-binding-stxes alignment-stx malloc-mode-stx property-stxes property-binding-stxes
no-equal?) no-equal? define-unsafe?)
(define change-unsafe-ids
(if define-unsafe?
(λ (x) x)
generate-temporaries))
(define name (define name
(cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
(define slot-names (map (lambda (x) (symbol->string (syntax-e x))) (define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
@ -1472,10 +1478,14 @@
[TYPE->list* (id name"->list*")] [TYPE->list* (id name"->list*")]
[TYPE-tag (id name"-tag")] [TYPE-tag (id name"-tag")]
[(stype ...) (ids (lambda (s) `(,name"-",s"-type")))] [(stype ...) (ids (lambda (s) `(,name"-",s"-type")))]
[(unsafe-TYPE-SLOT ...)
(change-unsafe-ids (ids (lambda (s) `("unsafe-",name"-",s))))]
[(unsafe-set-TYPE-SLOT! ...)
(change-unsafe-ids (ids (lambda (s) `("unsafe-set-",name"-",s"!"))))]
[(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))] [(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))]
[(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))] [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
[(offset ...) (generate-temporaries [(offset ...)
(ids (lambda (s) `(,s"-offset"))))] (change-unsafe-ids (ids (lambda (s) `(,name"-",s"-offset"))))]
[alignment alignment-stx] [alignment alignment-stx]
[malloc-mode (or malloc-mode-stx #'(quote atomic))]) [malloc-mode (or malloc-mode-stx #'(quote atomic))])
(with-syntax ([get-super-info (with-syntax ([get-super-info
@ -1491,13 +1501,11 @@
[add-equality-property (if no-equal? [add-equality-property (if no-equal?
#'values #'values
#'add-equality-property)]) #'add-equality-property)])
#'(define-values (make-wrap-TYPE struct:cpointer:TYPE) #'(define-values (struct:cpointer:TYPE
(let () make-wrap-TYPE
(define-values (struct:cpointer:TYPE _?
cpointer:TYPE _ref
? _set)
ref
set)
(make-struct-type 'cpointer:TYPE (make-struct-type 'cpointer:TYPE
struct:cpointer:super struct:cpointer:super
(if struct:cpointer:super (if struct:cpointer:super
@ -1515,18 +1523,17 @@
#f #f
(if struct:cpointer:super (if struct:cpointer:super
null null
'(0)))) '(0))))))]
(values cpointer:TYPE struct:cpointer:TYPE)))))]
[define-wrap-type (if (null? property-stxes) [define-wrap-type (if (null? property-stxes)
#'(define (wrap-TYPE-type t) #'(define wrap-TYPE-type
(super-wrap-type-type t)) (procedure-rename super-wrap-type-type 'wrap-TYPE-type))
#'(define (wrap-TYPE-type t) #'(define (wrap-TYPE-type t)
(make-ctype t (make-ctype t
values (λ (x) x)
(lambda (p) (lambda (p)
(and p (and p
(make-wrap-TYPE p))))))] (make-wrap-TYPE p))))))]
[(property-binding ...) property-binding-stxes] [([(property-binding-ids ...) . property-binding-form] ...) property-binding-stxes]
[(maybe-struct:TYPE ...) (if (null? property-stxes) [(maybe-struct:TYPE ...) (if (null? property-stxes)
null null
(list #'struct:cpointer:TYPE))]) (list #'struct:cpointer:TYPE))])
@ -1540,30 +1547,26 @@
(reverse (list (quote-syntax TYPE-SLOT) ...)) (reverse (list (quote-syntax TYPE-SLOT) ...))
(reverse (list (quote-syntax set-TYPE-SLOT!) ...)) (reverse (list (quote-syntax set-TYPE-SLOT!) ...))
#t)))) #t))))
(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag (define-values (super-pointer super-tags super-types super-offsets
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*
maybe-struct:TYPE ...)
(let-values ([(super-pointer super-tags super-types super-offsets
super->list* list*->super super->list* list*->super
struct:cpointer:super super-wrap-type-type) struct:cpointer:super super-wrap-type-type)
get-super-info] get-super-info)
property-binding ...) (define-values (property-binding-ids ...) . property-binding-form) ...
(define-cpointer-type _TYPE super-pointer) (define-cpointer-type _^TYPE super-pointer)
define-wrap-type define-wrap-type
;; these make it possible to use recursive pointer definitions ;; these make it possible to use recursive pointer definitions
(define _TYPE-pointer (wrap-TYPE-type _TYPE)) (define _TYPE-pointer (wrap-TYPE-type _^TYPE))
(define _TYPE-pointer/null (wrap-TYPE-type _TYPE/null)) (define _TYPE-pointer/null (wrap-TYPE-type _^TYPE/null))
(define-values (stype ...) (values slot-type ...)) (define-values (stype ...) (values slot-type ...))
(define types (list stype ...)) (define types (list stype ...))
(define alignment-v alignment) (define alignment-v alignment)
(define offsets (compute-offsets types alignment-v (list slot-offset ...))) (define offsets (compute-offsets types alignment-v (list slot-offset ...)))
(define-values (offset ...) (apply values offsets)) (define-values (offset ...) (apply values offsets))
(define all-tags (cons TYPE-tag super-tags)) (define all-tags (cons ^TYPE-tag super-tags))
(define _TYPE* (define _TYPE
;; c->scheme adjusts all tags ;; c->scheme adjusts all tags
(let* ([cst (make-cstruct-type types #f alignment-v)] (let* ([cst (make-cstruct-type types #f alignment-v)]
[t (_cpointer TYPE-tag cst)] [t (_cpointer ^TYPE-tag cst)]
[c->s (ctype-c->scheme t)]) [c->s (ctype-c->scheme t)])
(wrap-TYPE-type (wrap-TYPE-type
(make-ctype cst (ctype-scheme->c t) (make-ctype cst (ctype-scheme->c t)
@ -1576,22 +1579,29 @@
(values (append super-types (cdr types)) (values (append super-types (cdr types))
(append super-offsets (cdr offsets))) (append super-offsets (cdr offsets)))
(values types offsets))) (values types offsets)))
(define (TYPE-SLOT x)
(unless (TYPE? x) (begin
(raise-argument-error 'TYPE-SLOT struct-string x)) (define (unsafe-TYPE-SLOT x)
(ptr-ref x stype 'abs offset)) (ptr-ref x stype 'abs offset))
(define (TYPE-SLOT x)
(unless (^TYPE? x)
(raise-argument-error 'TYPE-SLOT struct-string x))
(unsafe-TYPE-SLOT x)))
... ...
(define (set-TYPE-SLOT! x slot) (begin
(unless (TYPE? x) (define (unsafe-set-TYPE-SLOT! x slot)
(raise-argument-error 'set-TYPE-SLOT! struct-string 0 x slot))
(ptr-set! x stype 'abs offset slot)) (ptr-set! x stype 'abs offset slot))
(define (set-TYPE-SLOT! x slot)
(unless (^TYPE? x)
(raise-argument-error 'set-TYPE-SLOT! struct-string 0 x slot))
(unsafe-set-TYPE-SLOT! x slot)))
... ...
(define make-TYPE (define make-TYPE
(if (and has-super? super-types super-offsets) (if (and has-super? super-types super-offsets)
;; init using all slots ;; init using all slots
(lambda vals (lambda vals
(if (= (length vals) (length all-types)) (if (= (length vals) (length all-types))
(let ([block (make-wrap-TYPE (malloc _TYPE* malloc-mode))]) (let ([block (make-wrap-TYPE (malloc _TYPE malloc-mode))])
(set-cpointer-tag! block all-tags) (set-cpointer-tag! block all-tags)
(for-each (lambda (type ofs value) (for-each (lambda (type ofs value)
(ptr-set! block type 'abs ofs value)) (ptr-set! block type 'abs ofs value))
@ -1601,7 +1611,7 @@
(length all-types) (length vals) vals))) (length all-types) (length vals) vals)))
;; normal initializer ;; normal initializer
(lambda (slot ...) (lambda (slot ...)
(let ([block (make-wrap-TYPE (malloc _TYPE* malloc-mode))]) (let ([block (make-wrap-TYPE (malloc _TYPE malloc-mode))])
(set-cpointer-tag! block all-tags) (set-cpointer-tag! block all-tags)
(ptr-set! block stype 'abs offset slot) (ptr-set! block stype 'abs offset slot)
... ...
@ -1610,9 +1620,9 @@
(define (list->TYPE vals) (apply make-TYPE vals)) (define (list->TYPE vals) (apply make-TYPE vals))
(define (list*->TYPE vals) (define (list*->TYPE vals)
(cond (cond
[(TYPE? vals) vals] [(^TYPE? vals) vals]
[(= (length vals) (length all-types)) [(= (length vals) (length all-types))
(let ([block (malloc _TYPE* malloc-mode)]) (let ([block (malloc _TYPE malloc-mode)])
(set-cpointer-tag! block all-tags) (set-cpointer-tag! block all-tags)
(for-each (for-each
(lambda (type ofs value) (lambda (type ofs value)
@ -1628,12 +1638,12 @@
[else (error '_TYPE "expecting ~s values, got ~s: ~e" [else (error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)])) (length all-types) (length vals) vals)]))
(define (TYPE->list x) (define (TYPE->list x)
(unless (TYPE? x) (unless (^TYPE? x)
(raise-argument-error 'TYPE-list struct-string x)) (raise-argument-error 'TYPE-list struct-string x))
(map (lambda (type ofs) (ptr-ref x type 'abs ofs)) (map (lambda (type ofs) (ptr-ref x type 'abs ofs))
all-types all-offsets)) all-types all-offsets))
(define (TYPE->list* x) (define (TYPE->list* x)
(unless (TYPE? x) (unless (^TYPE? x)
(raise-argument-error 'TYPE-list struct-string x)) (raise-argument-error 'TYPE-list struct-string x))
(map (lambda (type ofs) (map (lambda (type ofs)
(let-values (let-values
@ -1645,13 +1655,11 @@
(if T->list* (T->list* v) v))) (if T->list* (T->list* v) v)))
all-types all-offsets)) all-types all-offsets))
(cstruct-info (cstruct-info
_TYPE* 'set! _TYPE 'set!
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE _^TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE
struct:cpointer:TYPE wrap-TYPE-type) struct:cpointer:TYPE wrap-TYPE-type)
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag (define TYPE? ^TYPE? #;(procedure-rename 'TYPE?))
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... (define TYPE-tag ^TYPE-tag)))))
list->TYPE list*->TYPE TYPE->list TYPE->list*
maybe-struct:TYPE ...)))))))
(define (err what . xs) (define (err what . xs)
(apply raise-syntax-error #f (apply raise-syntax-error #f
(if (list? what) (apply string-append what) what) (if (list? what) (apply string-append what) what)
@ -1664,51 +1672,74 @@
(syntax-case #'type () (syntax-case #'type ()
[(t s) (values #'t #'s)] [(t s) (values #'t #'s)]
[_ (values #'type #f)])] [_ (values #'type #f)])]
[(alignment malloc-mode properties property-bindings no-equal?) [(alignment malloc-mode
properties property-bindings
no-equal? define-unsafe?)
(let loop ([more #'more] (let loop ([more #'more]
[alignment #f] [alignment #f]
[malloc-mode #f] [malloc-mode #f]
[properties null] [properties null]
[property-bindings null] [property-bindings null]
[no-equal? #f]) [no-equal? #f]
[define-unsafe? #f])
(define (head) (syntax-case more () [(x . _) #'x])) (define (head) (syntax-case more () [(x . _) #'x]))
(syntax-case more () (syntax-case more ()
[() (values alignment [() (values alignment
malloc-mode malloc-mode
(reverse properties) (reverse properties)
(reverse property-bindings) (reverse property-bindings)
no-equal?)] no-equal?
define-unsafe?)]
[(#:alignment) (err "missing expression for #:alignment" (head))] [(#:alignment) (err "missing expression for #:alignment" (head))]
[(#:alignment a . rest) [(#:alignment a . rest)
(not alignment) (not alignment)
(loop #'rest #'a malloc-mode properties property-bindings no-equal?)] (loop #'rest
#'a malloc-mode
properties property-bindings
no-equal? define-unsafe?)]
[(#:alignment a . rest) [(#:alignment a . rest)
(err "multiple specifications of #:alignment" (head))] (err "multiple specifications of #:alignment" (head))]
[(#:malloc-mode) (err "missing expression for #:malloc-mode" (head))] [(#:malloc-mode)
(err "missing expression for #:malloc-mode" (head))]
[(#:malloc-mode m . rest) [(#:malloc-mode m . rest)
(not malloc-mode) (not malloc-mode)
(loop #'rest alignment #'m properties property-bindings no-equal?)] (loop #'rest
alignment #'m
properties property-bindings
no-equal? define-unsafe?)]
[(#:malloc-mode m . rest) [(#:malloc-mode m . rest)
(err "multiple specifications of #:malloc-mode" (head))] (err "multiple specifications of #:malloc-mode" (head))]
[(#:property) (err "missing property expression for #:property" (head))] [(#:property)
[(#:property prop) (err "missing value expression for #:property" (head))] (err "missing property expression for #:property" (head))]
[(#:property prop)
(err "missing value expression for #:property" (head))]
[(#:property prop val . rest) [(#:property prop val . rest)
(let () (let ()
(define prop-id (car (generate-temporaries '(prop)))) (define prop-id (car (generate-temporaries '(prop))))
(define val-id (car (generate-temporaries '(prop-val)))) (define val-id (car (generate-temporaries '(prop-val))))
(loop #'rest (loop #'rest
alignment alignment malloc-mode
malloc-mode
(list* #`(cons #,prop-id #,val-id) properties) (list* #`(cons #,prop-id #,val-id) properties)
(list* (list (list val-id) #'val) (list* (list (list val-id) #'val)
(list (list prop-id) #'(check-is-property prop)) (list (list prop-id) #'(check-is-property prop))
property-bindings) property-bindings)
no-equal?))] no-equal? define-unsafe?))]
[(#:no-equal . rest) [(#:no-equal . rest)
(if no-equal? (if no-equal?
(err "multiple specifications of #:no-equal" (head)) (err "multiple specifications of #:no-equal" (head))
(loop #'rest alignment malloc-mode properties property-bindings #t))] (loop #'rest
[(x . _) (err (if (keyword? (syntax-e #'x)) alignment malloc-mode
properties property-bindings
#t define-unsafe?))]
[(#:define-unsafe . rest)
(if define-unsafe?
(err "multiple specifications of #:define-unsafe" (head))
(loop #'rest
alignment malloc-mode
properties property-bindings
no-equal? #t))]
[(x . _)
(err (if (keyword? (syntax-e #'x))
"unknown keyword" "unexpected form") "unknown keyword" "unexpected form")
#'x)] #'x)]
[else (err "bad syntax")]))]) [else (err "bad syntax")]))])
@ -1733,13 +1764,13 @@
#`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)
#`(#,_SUPER slot-type ...) #`(#,_SUPER slot-type ...)
#'(0 slot-offset ...) #'(0 slot-offset ...)
alignment alignment malloc-mode
malloc-mode properties property-bindings
properties no-equal? define-unsafe?)
property-bindings
no-equal?)
(make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) #`(slot-offset ...) (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) #`(slot-offset ...)
alignment malloc-mode properties property-bindings no-equal?))))] alignment malloc-mode
properties property-bindings
no-equal? define-unsafe?))))]
[(_ type () . more) [(_ type () . more)
(identifier? #'type) (identifier? #'type)
(err "must have either a supertype or at least one field")] (err "must have either a supertype or at least one field")]