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

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

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]))

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,7 +1131,16 @@ 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}: structure-type information compatible with @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
@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]);
currently, this information is correct only when no @racket[super-id] currently, this information is correct only when no @racket[super-id]
@ -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].}]}
@; ------------------------------------------------------------ @; ------------------------------------------------------------

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
;; Make the predicate function have the right inferred name (gensym 'TYPE))
(define (TYPE? x) (define _TYPE
(and (cpointer? x) (cpointer-has-tag? x TYPE-tag))) (_cpointer TYPE-tag ptr-type scheme->c c->scheme))
(values (_cpointer TYPE-tag ptr-type scheme->c c->scheme) (define _TYPE/null
(_cpointer/null TYPE-tag ptr-type scheme->c c->scheme) (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme))
TYPE? ;; Make the predicate function have the right inferred name
TYPE-tag)))))])) (define (TYPE? x)
(and (cpointer? x) (cpointer-has-tag? x 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
alignment-stx malloc-mode-stx property-stxes property-binding-stxes _TYPE-stx has-super? slot-names-stx slot-types-stx slot-offsets-stx
no-equal?) alignment-stx malloc-mode-stx property-stxes property-binding-stxes
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,42 +1501,39 @@
[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 (make-struct-type 'cpointer:TYPE
set) struct:cpointer:super
(make-struct-type 'cpointer:TYPE (if struct:cpointer:super
struct:cpointer:super 0
(if struct:cpointer:super 1)
0 0 #f
1) (add-equality-property
0 #f (append
(add-equality-property (if struct:cpointer:super
(append null
(if struct:cpointer:super (list
null (cons prop:cpointer 0)))
(list (list prop ...)))
(cons prop:cpointer 0))) (current-inspector)
(list prop ...))) #f
(current-inspector) (if struct:cpointer:super
#f null
(if struct:cpointer:super '(0))))))]
null
'(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,118 +1547,119 @@
(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! ... super->list* list*->super
list->TYPE list*->TYPE TYPE->list TYPE->list* struct:cpointer:super super-wrap-type-type)
maybe-struct:TYPE ...) get-super-info)
(let-values ([(super-pointer super-tags super-types super-offsets (define-values (property-binding-ids ...) . property-binding-form) ...
super->list* list*->super (define-cpointer-type _^TYPE super-pointer)
struct:cpointer:super super-wrap-type-type) define-wrap-type
get-super-info] ;; these make it possible to use recursive pointer definitions
property-binding ...) (define _TYPE-pointer (wrap-TYPE-type _^TYPE))
(define-cpointer-type _TYPE super-pointer) (define _TYPE-pointer/null (wrap-TYPE-type _^TYPE/null))
define-wrap-type (define-values (stype ...) (values slot-type ...))
;; these make it possible to use recursive pointer definitions (define types (list stype ...))
(define _TYPE-pointer (wrap-TYPE-type _TYPE)) (define alignment-v alignment)
(define _TYPE-pointer/null (wrap-TYPE-type _TYPE/null)) (define offsets (compute-offsets types alignment-v (list slot-offset ...)))
(define-values (stype ...) (values slot-type ...)) (define-values (offset ...) (apply values offsets))
(define types (list stype ...)) (define all-tags (cons ^TYPE-tag super-tags))
(define alignment-v alignment) (define _TYPE
(define offsets (compute-offsets types alignment-v (list slot-offset ...))) ;; c->scheme adjusts all tags
(define-values (offset ...) (apply values offsets)) (let* ([cst (make-cstruct-type types #f alignment-v)]
(define all-tags (cons TYPE-tag super-tags)) [t (_cpointer ^TYPE-tag cst)]
(define _TYPE* [c->s (ctype-c->scheme t)])
;; c->scheme adjusts all tags (wrap-TYPE-type
(let* ([cst (make-cstruct-type types #f alignment-v)] (make-ctype cst (ctype-scheme->c t)
[t (_cpointer TYPE-tag cst)] ;; hack: modify & reuse the procedure made by _cpointer
[c->s (ctype-c->scheme t)]) (lambda (p)
(wrap-TYPE-type (if p (set-cpointer-tag! p all-tags) (c->s p))
(make-ctype cst (ctype-scheme->c t) p)))))
;; hack: modify & reuse the procedure made by _cpointer (define-values (all-types all-offsets)
(lambda (p) (if (and has-super? super-types super-offsets)
(if p (set-cpointer-tag! p all-tags) (c->s p)) (values (append super-types (cdr types))
p))))) (append super-offsets (cdr offsets)))
(define-values (all-types all-offsets) (values types offsets)))
(if (and has-super? super-types super-offsets)
(values (append super-types (cdr types)) (begin
(append super-offsets (cdr offsets))) (define (unsafe-TYPE-SLOT x)
(values types offsets))) (ptr-ref x stype 'abs offset))
(define (TYPE-SLOT x) (define (TYPE-SLOT x)
(unless (TYPE? x) (unless (^TYPE? x)
(raise-argument-error 'TYPE-SLOT struct-string x)) (raise-argument-error 'TYPE-SLOT struct-string x))
(ptr-ref x stype 'abs offset)) (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)
(define make-TYPE (raise-argument-error 'set-TYPE-SLOT! struct-string 0 x slot))
(if (and has-super? super-types super-offsets) (unsafe-set-TYPE-SLOT! x slot)))
;; init using all slots ...
(lambda vals (define make-TYPE
(if (= (length vals) (length all-types)) (if (and has-super? super-types super-offsets)
(let ([block (make-wrap-TYPE (malloc _TYPE* malloc-mode))]) ;; init using all slots
(set-cpointer-tag! block all-tags) (lambda vals
(for-each (lambda (type ofs value) (if (= (length vals) (length all-types))
(ptr-set! block type 'abs ofs value)) (let ([block (make-wrap-TYPE (malloc _TYPE malloc-mode))])
all-types all-offsets vals)
block)
(error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)))
;; normal initializer
(lambda (slot ...)
(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) (for-each (lambda (type ofs value)
... (ptr-set! block type 'abs ofs value))
block)))) all-types all-offsets vals)
define-wrapper-struct block)
(define (list->TYPE vals) (apply make-TYPE vals)) (error '_TYPE "expecting ~s values, got ~s: ~e"
(define (list*->TYPE vals) (length all-types) (length vals) vals)))
(cond ;; normal initializer
[(TYPE? vals) vals] (lambda (slot ...)
[(= (length vals) (length all-types)) (let ([block (make-wrap-TYPE (malloc _TYPE malloc-mode))])
(let ([block (malloc _TYPE* malloc-mode)])
(set-cpointer-tag! block all-tags) (set-cpointer-tag! block all-tags)
(for-each (ptr-set! block stype 'abs offset slot)
(lambda (type ofs value) ...
(let-values block))))
([(ptr tags types offsets T->list* list*->T struct:T wrap) define-wrapper-struct
(cstruct-info (define (list->TYPE vals) (apply make-TYPE vals))
type (define (list*->TYPE vals)
(lambda () (values #f '() #f #f #f #f #f values)))]) (cond
(ptr-set! block type 'abs ofs [(^TYPE? vals) vals]
(if list*->T (list*->T value) value)))) [(= (length vals) (length all-types))
all-types all-offsets vals) (let ([block (malloc _TYPE malloc-mode)])
block)] (set-cpointer-tag! block all-tags)
[else (error '_TYPE "expecting ~s values, got ~s: ~e" (for-each
(length all-types) (length vals) vals)])) (lambda (type ofs value)
(define (TYPE->list x) (let-values
(unless (TYPE? x) ([(ptr tags types offsets T->list* list*->T struct:T wrap)
(raise-argument-error 'TYPE-list struct-string x)) (cstruct-info
(map (lambda (type ofs) (ptr-ref x type 'abs ofs)) type
all-types all-offsets)) (lambda () (values #f '() #f #f #f #f #f values)))])
(define (TYPE->list* x) (ptr-set! block type 'abs ofs
(unless (TYPE? x) (if list*->T (list*->T value) value))))
(raise-argument-error 'TYPE-list struct-string x)) all-types all-offsets vals)
(map (lambda (type ofs) block)]
(let-values [else (error '_TYPE "expecting ~s values, got ~s: ~e"
([(v) (ptr-ref x type 'abs ofs)] (length all-types) (length vals) vals)]))
[(ptr tags types offsets T->list* list*->T struct:T wrap) (define (TYPE->list x)
(cstruct-info (unless (^TYPE? x)
type (raise-argument-error 'TYPE-list struct-string x))
(lambda () (values #f '() #f #f #f #f #f values)))]) (map (lambda (type ofs) (ptr-ref x type 'abs ofs))
(if T->list* (T->list* v) v))) all-types all-offsets))
all-types all-offsets)) (define (TYPE->list* x)
(cstruct-info (unless (^TYPE? x)
_TYPE* 'set! (raise-argument-error 'TYPE-list struct-string x))
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE (map (lambda (type ofs)
struct:cpointer:TYPE wrap-TYPE-type) (let-values
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag ([(v) (ptr-ref x type 'abs ofs)]
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... [(ptr tags types offsets T->list* list*->T struct:T wrap)
list->TYPE list*->TYPE TYPE->list TYPE->list* (cstruct-info
maybe-struct:TYPE ...))))))) type
(lambda () (values #f '() #f #f #f #f #f values)))])
(if T->list* (T->list* v) v)))
all-types all-offsets))
(cstruct-info
_TYPE 'set!
_^TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE
struct:cpointer:TYPE wrap-TYPE-type)
(define TYPE? ^TYPE? #;(procedure-rename 'TYPE?))
(define TYPE-tag ^TYPE-tag)))))
(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,53 +1672,76 @@
(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
"unknown keyword" "unexpected form") properties property-bindings
#'x)] #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")
#'x)]
[else (err "bad syntax")]))]) [else (err "bad syntax")]))])
(unless (identifier? _TYPE) (unless (identifier? _TYPE)
(err "expecting a `_name' identifier or `(_name _super-name)'" (err "expecting a `_name' identifier or `(_name _super-name)'"
@ -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")]