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

some mz and ffi changes from the mr2 branch

Browse Source 
svn: r18099
This commit is contained in:
Matthew Flatt 2010-02-16 17:55:28 +00:00
parent a8fc2d55b3
commit 6f0d6b28de
19 changed files with 669 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
collects/ffi/objc.scrbl
View File

@ -54,6 +54,10 @@ The type of an Objective-C object, an opaque pointer.}
The type of an Objective-C class, which is also an @scheme[_id].}
@defthing[_Protocol ctype?]{
The type of an Objective-C protocol, which is also an @scheme[_id].}
@defthing[_SEL ctype?]{
The type of an Objective-C selector, an opaque pointer.}
@ -74,7 +78,7 @@ Synonym for @scheme[#f]}
@; ----------------------------------------------------------------------
@section{Syntactic Forms}
@section{Syntactic Forms and Procedures}
@defform*/subs[[(tell result-type obj-expr method-id)
(tell result-type obj-expr arg ...)]
@ -117,18 +121,39 @@ Defines each @scheme[class-id] to the class (a value with FFI type
(eval:alts (import-class NSString) (void))
]}
@defform[(import-protocol protocol-id ...)]{
Defines each @scheme[protocol-id] to the protocol (a value with FFI type
@scheme[_Protocol]) that is registered with the string form of
@scheme[protocol-id]. The registered class is obtained via
@scheme[objc_getProtocol].
@examples[
#:eval objc-eval
(eval:alts (import-protocol NSCoding) (void))
]}
@defform/subs[#:literals (+ - +a -a)
(define-objc-class class-id superclass-expr
maybe-mixins
maybe-protocols
[field-id ...]
method)
([method (mode result-ctype-expr (method-id) body ...+)
([maybe-mixins code:blank
(code:line #:mixins (mixin-expr ...))]
[maybe-protocols code:blank
(code:line #:protocols (protocol-expr ...))]
[method (mode result-ctype-expr (method-id) body ...+)
(mode result-ctype-expr (arg ...+) body ...+)]
[mode + - +a -a]
[arg (code:line method-id [ctype-expr arg-id])])]{
Defines @scheme[class-id] as a new, registered Objective-C class (of
FFI type @scheme[_Class]). The @scheme[superclass-expr] should
produce an Objective-C class or @scheme[#f] for the superclass.
FFI type @scheme[_Class]). The @scheme[superclass-expr] should produce
an Objective-C class or @scheme[#f] for the superclass. An optional
@scheme[#:mixins] clause can specify mixins defined with
@scheme[define-objc-mixin]. An optional @scheme[#:protocols] clause
can specify Objective-C protocols to be implemented by the class.
Each @scheme[field-id] is an instance field that holds a Scheme value
and that is initialized to @scheme[#f] when the object is
@ -170,19 +195,35 @@ space for each @scheme[field-id] within the instance is deallocated.
(void))
]}
@defform[(define-objc-mixin (class-id superclass-id)
maybe-mixins
maybe-protocols
[field-id ...]
method)]{
Like @scheme[define-objc-class], but defines a mixin to be combined
with other method definitions through either
@scheme[define-objc-class] or @scheme[define-objc-mixin]. The
specified @scheme[field-id]s are not added by the mixin, but must be a
subset of the @scheme[field-id]s declared for the class to which the
methods are added.}
@defidform[self]{
When used within the body of a @scheme[define-objc-class] method,
refers to the object whose method was called. This form cannot be used
outside of a @scheme[define-objc-class] method.}
When used within the body of a @scheme[define-objc-class] or
@scheme[define-objc-mixin] method, refers to the object whose method
was called. This form cannot be used outside of a
@scheme[define-objc-class] or @scheme[define-objc-mixin] method.}
@defform*[[(super-tell result-type method-id)
(super-tell result-type arg ...)]]{
When used within the body of a @scheme[define-objc-class] method,
calls a superclass method. The @scheme[result-type] and @scheme[arg]
sub-forms have the same syntax as in @scheme[tell]. This form cannot
be used outside of a @scheme[define-objc-class] method.}
When used within the body of a @scheme[define-objc-class] or
@scheme[define-objc-mixin] method, calls a superclass method. The
@scheme[result-type] and @scheme[arg] sub-forms have the same syntax
as in @scheme[tell]. This form cannot be used outside of a
@scheme[define-objc-class] or @scheme[define-objc-mixin] method.}
@defform[(get-ivar obj-expr field-id)]{
@ -204,6 +245,11 @@ Returns a selector (of FFI type @scheme[_SEL]) for the string form of
(eval:alts (tellv button setAction: #:type _SEL (selector terminate:)) (void))
]}
@defproc[(objc-is-a? [obj _id] [cls _Class]) boolean?]{
Check whether @scheme[obj] is an instance of the Objective-C class
@scheme[cls].}
@; ----------------------------------------------------------------------
@section{Raw Runtime Functions}
@ -212,6 +258,10 @@ Returns a selector (of FFI type @scheme[_SEL]) for the string form of
Finds a registered class by name.}
@defproc[(objc_getProtocol [s string?]) (or/c _Protocol #f)]{
Finds a registered protocol by name.}
@defproc[(sel_registerName [s string?]) _SEL]{
Interns a selector given its name in string form.}
@ -282,7 +332,7 @@ as the result type.}
Like @scheme[objc_msgSend/typed], but for a super call.}
@deftogether[(
@defproc[(make-obj_csuper [id _id] [super _Class]) _objc_super]
@defproc[(make-objc_super [id _id] [super _Class]) _objc_super]
@defthing[_objc_super ctype?]
)]{

168
collects/ffi/objc.ss
View File

@ -20,7 +20,7 @@
;; ----------------------------------------
(provide _id _Class _BOOL _SEL _Ivar
(provide _id _Class _Protocol _BOOL _SEL _Ivar
make-objc_super _objc_super)
(define _id (_cpointer/null 'id))
@ -32,6 +32,11 @@
(lambda (p)
(when p (cpointer-push-tag! p 'Class))
p)))
(define _Protocol (make-ctype _id
(lambda (v) v)
(lambda (p)
(when p (cpointer-push-tag! p 'Protocol))
p)))
(define _BOOL (make-ctype _byte
(lambda (v) (if v 1 0))
(lambda (v) (not (eq? v 0)))))
@ -46,6 +51,7 @@
;; ----------------------------------------
(define-objc objc_lookUpClass (_fun _string -> _Class))
(define-objc objc_getProtocol (_fun _string -> _Protocol))
(define-objc sel_registerName (_fun _string -> _SEL))
@ -65,32 +71,60 @@
-> (values ivar p)))
(define-objc object_setInstanceVariable (_fun _id _string _pointer -> _Ivar))
(define-objc class_addProtocol (_fun _Class _Protocol -> _BOOL))
(define-objc/private objc_msgSend _fpointer)
(define-objc/private objc_msgSend_fpret _fpointer)
(define-objc/private objc_msgSend_stret _fpointer)
(define-objc/private objc_msgSendSuper _fpointer)
(define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant?
(define-objc/private objc_msgSendSuper_stret _fpointer)
(define (lookup-send types msgSends msgSend msgSend_fpret first-arg-type)
(define sizes-for-direct-struct-results
(case (string->symbol (path->string (system-library-subpath #f)))
[(i386-macosx i386-darwin) '(1 2 4 8)]
[(ppc-macosx ppc-darwin) '(1 2 3 4)]
[(x86_64-macosx x86_86-darwin)
;; Do we need more analysis for unaligned fields?
'(1 2 3 4 5 6 7 8)]))
(define (lookup-send types msgSends msgSend msgSend_fpret msgSend_stret first-arg-type)
;; First type in `types' vector is the result type
(or (hash-ref msgSends types #f)
(let ([m (function-ptr (if (memq (ctype->layout (vector-ref types 0))
'(float double double*))
msgSend_fpret
msgSend)
(_cprocedure
(list* first-arg-type _SEL (cdr (vector->list types)))
(vector-ref types 0)))])
(hash-set! msgSends types m)
m)))
(let ([ret-layout (ctype->layout (vector-ref types 0))])
(if (and (list? ret-layout)
(not (memq (ctype-sizeof (vector-ref types 0))
sizes-for-direct-struct-results)))
;; Structure return type:
(let* ([pre-m (function-ptr msgSend_stret
(_cprocedure
(list* _pointer first-arg-type _SEL (cdr (vector->list types)))
_void))]
[m (lambda args
(let ([v (malloc (vector-ref types 0))])
(apply pre-m v args)
(ptr-ref v (vector-ref types 0))))])
(hash-set! msgSends types m)
m)
;; Non-structure return type:
(let ([m (function-ptr (if (memq ret-layout
'(float double double*))
msgSend_fpret
msgSend)
(_cprocedure
(list* first-arg-type _SEL (cdr (vector->list types)))
(vector-ref types 0)))])
(hash-set! msgSends types m)
m)))))
(define msgSends (make-hash))
(define (objc_msgSend/typed types)
(lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id))
(lookup-send types msgSends objc_msgSend objc_msgSend_fpret objc_msgSend_stret _id))
(provide* (unsafe objc_msgSend/typed))
(define msgSendSupers (make-hash))
(define (objc_msgSendSuper/typed types)
(lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret _pointer))
(lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret objc_msgSendSuper_stret _pointer))
(provide* (unsafe objc_msgSendSuper/typed))
;; ----------------------------------------
@ -104,6 +138,15 @@
[(_ id ...)
(syntax/loc stx (begin (import-class id) ...))]))
(provide* (unsafe import-protocol))
(define-syntax (import-protocol stx)
(syntax-case stx ()
[(_ id)
(quasisyntax/loc stx
(define id (objc_getProtocol #,(symbol->string (syntax-e #'id)))))]
[(_ id ...)
(syntax/loc stx (begin (import-protocol id) ...))]))
;; ----------------------------------------
;; iget-value and set-ivar! work only with fields that contain Scheme values
@ -329,23 +372,23 @@
;; ----------------------------------------
(provide* (unsafe define-objc-class) self super-tell)
(provide* (unsafe define-objc-class)
(unsafe define-objc-mixin)
self super-tell)
(define-for-syntax ((check-id stx what) id)
(unless (identifier? id)
(raise-syntax-error #f
(format "expected an identifier for ~a" what)
stx
id)))
(define-syntax (define-objc-class stx)
(syntax-case stx ()
[(_ id superclass (ivar ...) method ...)
[(_ id superclass #:mixins (mixin ...) #:protocols (proto ...) (ivar ...) method ...)
(begin
(unless (identifier? #'id)
(raise-syntax-error #f
"expected an identifier for class definition"
stx
#'id))
(for-each (lambda (ivar)
(unless (identifier? ivar)
(raise-syntax-error #f
"expected an identifier for an instance variable"
stx
ivar)))
((check-id stx "class definition") #'id)
(for-each (check-id stx "instance variable")
(syntax->list #'(ivar ...)))
(let ([ivars (syntax->list #'(ivar ...))]
[methods (syntax->list #'(method ...))])
@ -369,12 +412,56 @@
(begin
(define superclass-id superclass)
(define id (objc_allocateClassPair superclass-id id-str 0))
(void (class_addProtocol id proto)) ...
(add-ivar id 'ivar) ...
(let-syntax ([ivar (make-ivar-form 'ivar)] ...)
(add-method whole-stx id superclass-id method) ...
(mixin id superclass-id '(ivar ...)) ...
(add-method whole-stx id superclass-id dealloc-method) ...
(void))
(objc_registerClassPair id))))))]))
(objc_registerClassPair id))))))]
[(_ id superclass (ivar ...) method ...)
#'(define-objc-class id superclass #:mixins () #:protocols () (ivar ...) method ...)]
[(_ id superclass #:mixins (mixin ...) (ivar ...) method ...)
#'(define-objc-class id superclass #:mixins (mixin ...) #:protocols () (ivar ...) method ...)]
[(_ id superclass #:protocols (proto ...) (ivar ...) method ...)
#'(define-objc-class id superclass #:mixins () #:protocols (proto ...) (ivar ...) method ...)]))
(define (check-expected-ivars id got-ivars expected-ivars)
(when (ormap (lambda (s) (not (memq s got-ivars)))
expected-ivars)
(error id "expected to mix into class with at least ivars: ~s; mixed into class with ivars: ~s"
expected-ivars
got-ivars)))
(define-syntax (define-objc-mixin stx)
(syntax-case stx ()
[(_ (id superclass-id) #:mixins (mixin ...) #:protocols (proto ...) (ivar ...) method ...)
(begin
((check-id stx "class definition") #'id)
((check-id stx "superclass") #'superclass-id)
(for-each (check-id stx "instance variable")
(syntax->list #'(ivar ...)))
(with-syntax ([whole-stx stx]
[(mixin-id ...) (generate-temporaries #'(mixin ...))]
[(proto-id ...) (generate-temporaries #'(proto ...))])
(syntax/loc stx
(define id
(let ([mixin-id mixin] ...
[protocol-id proto] ...)
(lambda (to-id superclass-id ivars)
(check-expected-ivars 'id ivars '(ivar ...))
(void (class_addProtocol to-id proto-id)) ...
(let-syntax ([ivar (make-ivar-form 'ivar)] ...)
(add-method whole-stx to-id superclass-id method) ...
(void))
(mixin-id to-id superclass-id ivars) ...))))))]
[(_ (id superclass) (ivar ...) method ...)
#'(define-objc-mixin (id superclass) #:mixins () #:protocols () (ivar ...) method ...)]
[(_ (id superclass) #:mixins (mixin ...) (ivar ...) method ...)
#'(define-objc-mixin (id superclass) #:mixins (mixin ...) #:protocols () (ivar ...) method ...)]
[(_ (id superclass) #:protocols (proto ...) (ivar ...) method ...)
#'(define-objc-mixin (id superclass) #:mixins () #:protocols (proto ...) (ivar ...) method ...)]))
(define-for-syntax (make-ivar-form sym)
(with-syntax ([sym sym])
@ -477,7 +564,7 @@
[(dealloc-body ...)
(if (eq? (syntax-e id) 'dealloc)
(syntax-case stx ()
[(_ _ _ [ivar ...] . _)
[(_ _ _ #:mixins _ #:protocols _ [ivar ...] . _)
(with-syntax ([(ivar-str ...)
(map (lambda (ivar)
(symbol->string (syntax-e ivar)))
@ -491,19 +578,19 @@
#'cls)]
[atomic? (or (free-identifier=? #'kind #'+a)
(free-identifier=? #'kind #'-a))])
(syntax/loc stx
(quasisyntax/loc stx
(let ([rt result-type]
[arg-id arg-type] ...)
(void (class_addMethod in-cls
(sel_registerName id-str)
(save-method!
(lambda (self-id cmd arg-id ...)
(syntax-parameterize ([self (make-id-stx #'self-id)]
[super-class (make-id-stx #'superclass-id)]
[super-tell do-super-tell])
body0 body ...
dealloc-body ...)))
(_fun #:atomic? atomic? _id _id arg-type ... -> rt)
#,(syntax/loc #'m
(lambda (self-id cmd arg-id ...)
(syntax-parameterize ([self (make-id-stx #'self-id)]
[super-class (make-id-stx #'superclass-id)]
[super-tell do-super-tell])
body0 body ...
dealloc-body ...)))
(_fun #:atomic? atomic? #:keep save-method! _id _id arg-type ... -> rt)
(generate-layout rt (list arg-id ...)))))))))]
[else (raise-syntax-error #f
"bad method form"
@ -557,5 +644,12 @@
;; --------------------------------------------------
(provide* (unsafe objc-is-a?))
(define (objc-is-a? v c)
(ptr-equal? (object_getClass v) c))
;; ----------------------------------------
(define-unsafer objc-unsafe!)

14
collects/ffi/private/objc-doc-unsafe.ss
View File

@ -9,8 +9,20 @@
(provide (protect-out objc_msgSend/typed
objc_msgSendSuper/typed
import-class
import-protocol
get-ivar set-ivar!
selector
tell tellv
define-objc-class)
define-objc-class
define-objc-mixin
objc_lookUpClass
objc_getProtocol
sel_registerName
objc_allocateClassPair
objc_registerClassPair
object_getClass
class_addIvar
object_getInstanceVariable
object_setInstanceVariable
objc-is-a?)
(all-from-out ffi/objc))

216
collects/scheme/foreign.ss
View File

@ -2,7 +2,8 @@
;; Foreign Scheme interface
(require '#%foreign setup/dirs scheme/unsafe/ops
(for-syntax scheme/base scheme/list syntax/stx))
(for-syntax scheme/base scheme/list syntax/stx
scheme/struct-info))
;; This module is full of unsafe bindings that are not provided to requiring
;; modules. Instead, an `unsafe!' binding is provided that makes these unsafe
@ -1451,6 +1452,7 @@
[struct-string (format "struct:~a" name)]
[(slot ...) slot-names-stx]
[(slot-type ...) slot-types-stx]
[TYPE (id name)]
[_TYPE _TYPE-stx]
[_TYPE-pointer (id "_"name"-pointer")]
[_TYPE-pointer/null (id "_"name"-pointer/null")]
@ -1475,109 +1477,119 @@
#'(values #f '() #f #f #f #f)
#`(cstruct-info #,1st-type
(lambda () (values #f '() #f #f #f #f))))])
#'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*)
(let-values ([(super-pointer super-tags super-types super-offsets
super->list* list*->super)
get-super-info])
(define-cpointer-type _TYPE super-pointer)
;; these makes it possible to use recursive pointer definitions
(define _TYPE-pointer _TYPE)
(define _TYPE-pointer/null _TYPE/null)
(let*-values ([(stype ...) (values slot-type ...)]
[(types) (list stype ...)]
[(offsets) (compute-offsets types)]
[(offset ...) (apply values offsets)])
(define all-tags (cons TYPE-tag super-tags))
(define _TYPE*
;; c->scheme adjusts all tags
(let* ([cst (make-cstruct-type types)]
[t (_cpointer TYPE-tag cst)]
[c->s (ctype-c->scheme t)])
(make-ctype cst (ctype-scheme->c t)
;; hack: modify & reuse the procedure made by _cpointer
(lambda (p)
(if p (set-cpointer-tag! p all-tags) (c->s p))
p))))
(define-values (all-types all-offsets)
(if (and has-super? super-types super-offsets)
(values (append super-types (cdr types))
(append super-offsets (cdr offsets)))
(values types offsets)))
(define (TYPE-SLOT x)
(unless (TYPE? x)
(raise-type-error 'TYPE-SLOT struct-string x))
(ptr-ref x stype 'abs offset))
...
(define (set-TYPE-SLOT! x slot)
(unless (TYPE? x)
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
(ptr-set! x stype 'abs offset slot))
...
(define make-TYPE
(if (and has-super? super-types super-offsets)
;; init using all slots
(lambda vals
(if (= (length vals) (length all-types))
(let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(for-each (lambda (type ofs value)
(ptr-set! block type 'abs ofs value))
all-types all-offsets vals)
block)
(error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)))
;; normal initializer
(lambda (slot ...)
#'(begin
(define-syntax TYPE
(make-struct-info
(lambda ()
(list #f ; no struct:
(quote-syntax make-TYPE)
(quote-syntax TYPE?)
(reverse (list (quote-syntax TYPE-SLOT) ...))
(reverse (list (quote-syntax set-TYPE-SLOT!) ...))
#t))))
(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*)
(let-values ([(super-pointer super-tags super-types super-offsets
super->list* list*->super)
get-super-info])
(define-cpointer-type _TYPE super-pointer)
;; these makes it possible to use recursive pointer definitions
(define _TYPE-pointer _TYPE)
(define _TYPE-pointer/null _TYPE/null)
(let*-values ([(stype ...) (values slot-type ...)]
[(types) (list stype ...)]
[(offsets) (compute-offsets types)]
[(offset ...) (apply values offsets)])
(define all-tags (cons TYPE-tag super-tags))
(define _TYPE*
;; c->scheme adjusts all tags
(let* ([cst (make-cstruct-type types)]
[t (_cpointer TYPE-tag cst)]
[c->s (ctype-c->scheme t)])
(make-ctype cst (ctype-scheme->c t)
;; hack: modify & reuse the procedure made by _cpointer
(lambda (p)
(if p (set-cpointer-tag! p all-tags) (c->s p))
p))))
(define-values (all-types all-offsets)
(if (and has-super? super-types super-offsets)
(values (append super-types (cdr types))
(append super-offsets (cdr offsets)))
(values types offsets)))
(define (TYPE-SLOT x)
(unless (TYPE? x)
(raise-type-error 'TYPE-SLOT struct-string x))
(ptr-ref x stype 'abs offset))
...
(define (set-TYPE-SLOT! x slot)
(unless (TYPE? x)
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
(ptr-set! x stype 'abs offset slot))
...
(define make-TYPE
(if (and has-super? super-types super-offsets)
;; init using all slots
(lambda vals
(if (= (length vals) (length all-types))
(let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(for-each (lambda (type ofs value)
(ptr-set! block type 'abs ofs value))
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 (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(ptr-set! block stype 'abs offset slot)
...
block))))
(define (list->TYPE vals) (apply make-TYPE vals))
(define (list*->TYPE vals)
(cond
[(TYPE? vals) vals]
[(= (length vals) (length all-types))
(let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(ptr-set! block stype 'abs offset slot)
...
block))))
(define (list->TYPE vals) (apply make-TYPE vals))
(define (list*->TYPE vals)
(cond
[(TYPE? vals) vals]
[(= (length vals) (length all-types))
(let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags)
(for-each
(lambda (type ofs value)
(let-values
([(ptr tags types offsets T->list* list*->T)
(cstruct-info
type
(lambda () (values #f '() #f #f #f #f)))])
(ptr-set! block type 'abs ofs
(if list*->T (list*->T value) value))))
all-types all-offsets vals)
block)]
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)]))
(define (TYPE->list x)
(unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
all-types all-offsets))
(define (TYPE->list* x)
(unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs)
(let-values
([(v) (ptr-ref x type 'abs ofs)]
[(ptr tags types offsets T->list* list*->T)
(cstruct-info
type
(lambda () (values #f '() #f #f #f #f)))])
(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)
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))
(for-each
(lambda (type ofs value)
(let-values
([(ptr tags types offsets T->list* list*->T)
(cstruct-info
type
(lambda () (values #f '() #f #f #f #f)))])
(ptr-set! block type 'abs ofs
(if list*->T (list*->T value) value))))
all-types all-offsets vals)
block)]
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)]))
(define (TYPE->list x)
(unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
all-types all-offsets))
(define (TYPE->list* x)
(unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x))
(map (lambda (type ofs)
(let-values
([(v) (ptr-ref x type 'abs ofs)]
[(ptr tags types offsets T->list* list*->T)
(cstruct-info
type
(lambda () (values #f '() #f #f #f #f)))])
(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)
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*))))))))
(define (identifiers? stx)
(andmap identifier? (syntax->list stx)))
(define (_-identifier? id stx)

8
collects/scribblings/foreign/types.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/doc
@(require "utils.ss")
@(require "utils.ss"
(for-label scheme/match))
@title[#:tag "types" #:style 'toc]{C Types}
@ -780,6 +781,11 @@ The resulting bindings are as follows:
@item{@schemeidfont{set-}@schemevarfont{id}@schemeidfont{-}@scheme[field-id]@schemeidfont{!}
: a mutator function for each @scheme[field-id].}
@item{@schemevarfont{id}: structure-type information compatible with
@scheme[struct-out] or @scheme[match] (but not @scheme[define-struct]);
currently, this information is correct only when no @scheme[super-id]
is specified.}
]
Objects of the new type are actually C pointers, with a type tag that

2
collects/scribblings/reference/syntax.scrbl
View File

@ -776,7 +776,7 @@ follows.
@defsubform[(struct-out id)]{Exports the bindings associated with a
structure type @scheme[id]. Typically, @scheme[id] is bound with
@scheme[(define-struct id ....)] or @scheme[(define-struct (id
super-id) ....)]; more generally, @scheme[id] must have a
_super-id) ....)]; more generally, @scheme[id] must have a
@tech{transformer binding} of structure-type information at
@tech{phase level} 0; see @secref["structinfo"]. Furthermore, for
each identifier mentioned in the structure-type information, the

4
src/mzscheme/include/mzscheme.exp
View File

@ -79,6 +79,9 @@ scheme_pop_kill_action
scheme_set_can_break
scheme_push_break_enable
scheme_pop_break_enable
scheme_with_stack_freeze
scheme_frozen_run_some
scheme_is_in_frozen_stack
scheme_signal_error
scheme_raise_exn
scheme_warning
@ -485,7 +488,6 @@ scheme_print_utf8
scheme_print_string
scheme_read_byte_string
scheme_make_namespace
scheme_add_namespace_option
scheme_add_global
scheme_add_global_symbol
scheme_make_envunbox

4
src/mzscheme/include/mzscheme3m.exp
View File

@ -79,6 +79,9 @@ scheme_pop_kill_action
scheme_set_can_break
scheme_push_break_enable
scheme_pop_break_enable
scheme_with_stack_freeze
scheme_frozen_run_some
scheme_is_in_frozen_stack
scheme_signal_error
scheme_raise_exn
scheme_warning
@ -491,7 +494,6 @@ scheme_print_utf8
scheme_print_string
scheme_read_byte_string
scheme_make_namespace
scheme_add_namespace_option
scheme_add_global
scheme_add_global_symbol
scheme_make_envunbox

4
src/mzscheme/include/mzwin.def
View File

@ -81,6 +81,9 @@ EXPORTS
scheme_set_can_break
scheme_push_break_enable
scheme_pop_break_enable
scheme_with_stack_freeze
scheme_frozen_run_some
scheme_is_in_frozen_stack
scheme_signal_error
scheme_raise_exn
scheme_warning
@ -468,7 +471,6 @@ EXPORTS
scheme_print_string
scheme_read_byte_string
scheme_make_namespace
scheme_add_namespace_option
scheme_add_global
scheme_add_global_symbol
scheme_make_envunbox

4
src/mzscheme/include/mzwin3m.def
View File

@ -81,6 +81,9 @@ EXPORTS
scheme_set_can_break
scheme_push_break_enable
scheme_pop_break_enable
scheme_with_stack_freeze
scheme_frozen_run_some
scheme_is_in_frozen_stack
scheme_signal_error
scheme_raise_exn
scheme_warning
@ -483,7 +486,6 @@ EXPORTS
scheme_print_string
scheme_read_byte_string
scheme_make_namespace
scheme_add_namespace_option
scheme_add_global
scheme_add_global_symbol
scheme_make_envunbox

1
src/mzscheme/include/scheme.h
View File

@ -1137,6 +1137,7 @@ typedef void (*Scheme_Kill_Action_Func)(void *);
thread->error_buf = savebuf; \
thread = NULL; } }
typedef int (*Scheme_Frozen_Stack_Proc)(void *);
/*========================================================================*/
/* parameters */

33
src/mzscheme/src/mzmark.c
View File

@ -4432,6 +4432,39 @@ static int mark_thread_cell_FIXUP(void *p) {
#define mark_thread_cell_IS_CONST_SIZE 1
static int mark_frozen_tramp_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(FrozenTramp));
}
static int mark_frozen_tramp_MARK(void *p) {
FrozenTramp *f = (FrozenTramp *)p;
gcMARK(f->do_data);
gcMARK(f->old_param);
gcMARK(f->config);
gcMARK(f->progress_cont);
return
gcBYTES_TO_WORDS(sizeof(FrozenTramp));
}
static int mark_frozen_tramp_FIXUP(void *p) {
FrozenTramp *f = (FrozenTramp *)p;
gcFIXUP(f->do_data);
gcFIXUP(f->old_param);
gcFIXUP(f->config);
gcFIXUP(f->progress_cont);
return
gcBYTES_TO_WORDS(sizeof(FrozenTramp));
}
#define mark_frozen_tramp_IS_ATOMIC 0
#define mark_frozen_tramp_IS_CONST_SIZE 1
#endif /* THREAD */
/**********************************************************************/

13
src/mzscheme/src/mzmarksrc.c
View File

@ -1804,6 +1804,19 @@ mark_thread_cell {
gcBYTES_TO_WORDS(sizeof(Thread_Cell));
}
mark_frozen_tramp {
mark:
FrozenTramp *f = (FrozenTramp *)p;
gcMARK(f->do_data);
gcMARK(f->old_param);
gcMARK(f->config);
gcMARK(f->progress_cont);
size:
gcBYTES_TO_WORDS(sizeof(FrozenTramp));
}
END thread;
/**********************************************************************/

4
src/mzscheme/src/schemef.h
View File

@ -176,6 +176,10 @@ MZ_EXTERN void scheme_set_can_break(int on);
MZ_EXTERN void scheme_push_break_enable(Scheme_Cont_Frame_Data *cframe, int on, int pre_check);
MZ_EXTERN void scheme_pop_break_enable(Scheme_Cont_Frame_Data *cframe, int post_check);
MZ_EXTERN int scheme_with_stack_freeze(Scheme_Frozen_Stack_Proc wha_f, void *wha_data);
MZ_EXTERN int scheme_frozen_run_some(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs);
MZ_EXTERN int scheme_is_in_frozen_stack();
/*========================================================================*/
/* error handling */
/*========================================================================*/

3
src/mzscheme/src/schemex.h
View File

@ -139,6 +139,9 @@ void (*scheme_pop_kill_action)();
void (*scheme_set_can_break)(int on);
void (*scheme_push_break_enable)(Scheme_Cont_Frame_Data *cframe, int on, int pre_check);
void (*scheme_pop_break_enable)(Scheme_Cont_Frame_Data *cframe, int post_check);
int (*scheme_with_stack_freeze)(Scheme_Frozen_Stack_Proc wha_f, void *wha_data);
int (*scheme_frozen_run_some)(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs);
int (*scheme_is_in_frozen_stack)();
/*========================================================================*/
/* error handling */
/*========================================================================*/

3
src/mzscheme/src/schemex.inc
View File

@ -87,6 +87,9 @@
scheme_extension_table->scheme_set_can_break = scheme_set_can_break;
scheme_extension_table->scheme_push_break_enable = scheme_push_break_enable;
scheme_extension_table->scheme_pop_break_enable = scheme_pop_break_enable;
scheme_extension_table->scheme_with_stack_freeze = scheme_with_stack_freeze;
scheme_extension_table->scheme_frozen_run_some = scheme_frozen_run_some;
scheme_extension_table->scheme_is_in_frozen_stack = scheme_is_in_frozen_stack;
scheme_extension_table->scheme_signal_error = scheme_signal_error;
scheme_extension_table->scheme_raise_exn = scheme_raise_exn;
scheme_extension_table->scheme_warning = scheme_warning;

3
src/mzscheme/src/schemexm.h
View File

@ -87,6 +87,9 @@
#define scheme_set_can_break (scheme_extension_table->scheme_set_can_break)
#define scheme_push_break_enable (scheme_extension_table->scheme_push_break_enable)
#define scheme_pop_break_enable (scheme_extension_table->scheme_pop_break_enable)
#define scheme_with_stack_freeze (scheme_extension_table->scheme_with_stack_freeze)
#define scheme_frozen_run_some (scheme_extension_table->scheme_frozen_run_some)
#define scheme_is_in_frozen_stack (scheme_extension_table->scheme_is_in_frozen_stack)
#define scheme_signal_error (scheme_extension_table->scheme_signal_error)
#define scheme_raise_exn (scheme_extension_table->scheme_raise_exn)
#define scheme_warning (scheme_extension_table->scheme_warning)

1
src/mzscheme/src/stypes.h
View File

@ -249,6 +249,7 @@ enum {
scheme_rt_sfs_info, /* 227 */
scheme_rt_validate_clearing, /* 228 */
scheme_rt_rb_node, /* 229 */
scheme_rt_frozen_tramp, /* 230 */
#endif

273
src/mzscheme/src/thread.c
View File

@ -100,7 +100,7 @@ extern HANDLE scheme_break_semaphore;
# define SENORA_GC_NO_FREE
#endif
/* If a finalization callback in MrEd invokes Scheme code,
/* If a finalization callback invokes Scheme code,
we can end up with a thread swap in the middle of a thread
swap (where the outer swap was interrupted by GC). The
following is a debugging flag to help detect and fix
@ -209,8 +209,7 @@ HOOK_SHARED_OK void (*scheme_on_atomic_timeout)(void);
ROSYM static Scheme_Object *read_symbol, *write_symbol, *execute_symbol, *delete_symbol, *exists_symbol;
ROSYM static Scheme_Object *client_symbol, *server_symbol;
ROSYM static Scheme_Object *froz_key;
THREAD_LOCAL_DECL(static int do_atomic = 0);
THREAD_LOCAL_DECL(static int missed_context_switch = 0);
@ -448,6 +447,9 @@ void scheme_init_thread(Scheme_Env *env)
client_symbol = scheme_intern_symbol("client");
server_symbol = scheme_intern_symbol("server");
REGISTER_SO(froz_key);
froz_key = scheme_make_symbol("frozen"); /* uninterned */
scheme_add_global_constant("dump-memory-stats",
scheme_make_prim_w_arity(scheme_dump_gc_stats,
"dump-memory-stats",
@ -3215,7 +3217,7 @@ Scheme_Object *scheme_thread_w_details(Scheme_Object *thunk,
Scheme_Thread *p = scheme_current_thread;
/* Don't mangle the stack if we're in atomic mode, because that
probably means a MrEd HET trampoline, etc. */
probably means a stack-freeze trampoline, etc. */
wait_until_suspend_ok();
p->ku.k.p1 = thunk;
@ -7631,6 +7633,266 @@ void scheme_free_gmp(void *p, void **mem_pool)
*mem_pool = SCHEME_CDR(*mem_pool);
}
/*========================================================================*/
/* stack freezer */
/*========================================================================*/
/* When interacting with certain libraries that can lead to Scheme
callbacks, the stack region used by the library should not be
modified by Scheme thread swaps. In that case, the callback must be
constrained. Completely disallowing synchornization with ther
threads or unbounded computation, however, is sometimes too
difficult. A stack-freezer sequence offer a compromise, where the
callback is run as much as possible, but it can be suspended to
allow the library call to return so that normal Scheme-thread
scheduling can resume. The callback is then completed in a normal
scheduling context, where it is no longer specially constrained.
The call process is
scheme_with_stack_freeze(f, data)
-> f(data) in frozen mode
-> ... frozen_run_some(g, data2) \
-> Scheme code, may finish or may not | maybe loop
froz->in_progress inicates whether done /
-> continue scheme if not finished
In this process, it's the call stack between f(data) and the call
to frozen_run_some() that won't be copied in or out until f(data)
returns.
Nesting scheme_with_stack_freeze() calls should be safe, but it
won't achieve the goal, which is to limit the amount of work done
before returning (because the inner scheme_with_stack_freeze() will
have to run to completion). */
static unsigned long get_deeper_base();
typedef struct FrozenTramp {
MZTAG_IF_REQUIRED
Scheme_Frozen_Stack_Proc do_f;
void *do_data;
int val;
int in_progress;
int progress_is_resumed;
Scheme_Object *old_param;
Scheme_Config *config;
void *progress_base_addr;
mz_jmp_buf progress_base;
Scheme_Jumpup_Buf_Holder *progress_cont;
int timer_on;
double continue_until;
#ifdef MZ_PRECISE_GC
void *fixup_var_stack_chain;
#endif
} FrozenTramp;
int scheme_with_stack_freeze(Scheme_Frozen_Stack_Proc wha_f, void *wha_data)
{
FrozenTramp *froz;
Scheme_Cont_Frame_Data cframe;
Scheme_Object *bx;
int retval;
Scheme_Jumpup_Buf_Holder *pc;
froz = MALLOC_ONE_RT(FrozenTramp);
SET_REQUIRED_TAG(froz->type = scheme_rt_frozen_tramp);
bx = scheme_make_raw_pair((Scheme_Object *)froz, NULL);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(froz_key, bx);
pc = scheme_new_jmpupbuf_holder();
froz->progress_cont = pc;
scheme_init_jmpup_buf(&froz->progress_cont->buf);
scheme_start_atomic();
retval = wha_f(wha_data);
froz->val = retval;
if (froz->in_progress) {
/* We have leftover work; jump and finish it (non-atomically).
But don't swap until we've jumped back in, because the jump-in
point might be trying to suspend the thread (and that should
complete before any swap). */
scheme_end_atomic_no_swap();
SCHEME_CAR(bx) = NULL;
froz->in_progress = 0;
froz->progress_is_resumed = 1;
if (!scheme_setjmp(froz->progress_base)) {
#ifdef MZ_PRECISE_GC
froz->fixup_var_stack_chain = &__gc_var_stack__;
#endif
scheme_longjmpup(&froz->progress_cont->buf);
}
} else {
scheme_end_atomic();
}
scheme_pop_continuation_frame(&cframe);
froz->old_param = NULL;
froz->progress_cont = NULL;
froz->do_data = NULL;
return froz->val;
}
static void suspend_froz_progress(void)
{
FrozenTramp * volatile froz;
double msecs;
Scheme_Object *v;
v = scheme_extract_one_cc_mark(NULL, froz_key);
froz = (FrozenTramp *)SCHEME_CAR(v);
v = NULL;
msecs = scheme_get_inexact_milliseconds();
if (msecs < froz->continue_until)
return;
scheme_on_atomic_timeout = NULL;
froz->in_progress = 1;
if (scheme_setjmpup(&froz->progress_cont->buf, (void*)froz->progress_cont, froz->progress_base_addr)) {
/* we're back */
scheme_reset_jmpup_buf(&froz->progress_cont->buf);
#ifdef MZ_PRECISE_GC
/* Base addr points to the last valid gc_var_stack address.
Fixup that link to skip over the part of the stack we're
not using right now. */
((void **)froz->progress_base_addr)[0] = froz->fixup_var_stack_chain;
((void **)froz->progress_base_addr)[1] = NULL;
#endif
} else {
/* we're leaving */
scheme_longjmp(froz->progress_base, 1);
}
}
static void froz_run_new(FrozenTramp * volatile froz, int run_msecs)
{
double msecs;
/* We're willing to start new work that is specific to this thread */
froz->progress_is_resumed = 0;
msecs = scheme_get_inexact_milliseconds();
froz->continue_until = msecs + run_msecs;
if (!scheme_setjmp(froz->progress_base)) {
Scheme_Frozen_Stack_Proc do_f;
scheme_start_atomic();
scheme_on_atomic_timeout = suspend_froz_progress;
do_f = froz->do_f;
do_f(froz->do_data);
}
if (froz->progress_is_resumed) {
/* we've already returned once; jump out to new progress base */
scheme_longjmp(froz->progress_base, 1);
} else {
scheme_on_atomic_timeout = NULL;
scheme_end_atomic_no_swap();
}
}
static void froz_do_run_new(FrozenTramp * volatile froz, int *iteration, int run_msecs)
{
/* This function just makes room on the stack, eventually calling
froz_run_new(). */
int new_iter[32];
if (iteration[0] == 3) {
#ifdef MZ_PRECISE_GC
froz->progress_base_addr = (void *)&__gc_var_stack__;
#else
froz->progress_base_addr = (void *)new_iter;
#endif
froz_run_new(froz, run_msecs);
} else {
new_iter[0] = iteration[0] + 1;
froz_do_run_new(froz, new_iter, run_msecs);
}
}
int scheme_frozen_run_some(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs)
{
FrozenTramp * volatile froz;
int more = 0;
Scheme_Object *v;
v = scheme_extract_one_cc_mark(NULL, froz_key);
if (v)
froz = (FrozenTramp *)SCHEME_CAR(v);
else
froz = NULL;
v = NULL;
if (froz) {
if (froz->in_progress) {
/* We have work in progress. */
if ((unsigned long)froz->progress_base_addr < get_deeper_base()) {
/* We have stack space to resume the old work: */
double msecs;
froz->in_progress = 0;
froz->progress_is_resumed = 1;
msecs = scheme_get_inexact_milliseconds();
froz->continue_until = msecs + run_msecs;
scheme_start_atomic();
scheme_on_atomic_timeout = suspend_froz_progress;
if (!scheme_setjmp(froz->progress_base)) {
#ifdef MZ_PRECISE_GC
froz->fixup_var_stack_chain = &__gc_var_stack__;
#endif
scheme_longjmpup(&froz->progress_cont->buf);
} else {
scheme_on_atomic_timeout = NULL;
scheme_end_atomic_no_swap();
}
}
} else {
int iter[1];
iter[0] = 0;
froz->do_f = do_f;
froz->do_data = do_data;
froz_do_run_new(froz, iter, run_msecs);
}
more = froz->in_progress;
}
return more;
}
int scheme_is_in_frozen_stack()
{
Scheme_Object *v;
v = scheme_extract_one_cc_mark(NULL, froz_key);
if (v)
return 1;
else
return 0;
}
/* Disable warning for returning address of local variable: */
#ifdef _MSC_VER
#pragma warning (disable:4172)
#endif
static unsigned long get_deeper_base()
{
long here;
return (unsigned long)&here;
}
#ifdef _MSC_VER
#pragma warning (default:4172)
#endif
/*========================================================================*/
/* precise GC */
/*========================================================================*/
@ -7638,7 +7900,7 @@ void scheme_free_gmp(void *p, void **mem_pool)
Scheme_Jumpup_Buf_Holder *scheme_new_jmpupbuf_holder(void)
/* Scheme_Jumpup_Buf_Holder exists for precise GC, and for external
programs that want to store Jumpup_Bufs, because the GC interaction
is tricky. For example, MrEd uses it for a special trampoline
is tricky. For example, we use it above for a special trampoline
implementation. */
{
Scheme_Jumpup_Buf_Holder *h;
@ -7683,6 +7945,7 @@ static void register_traversers(void)
GC_REG_TRAV(scheme_rt_evt, mark_evt);
GC_REG_TRAV(scheme_rt_syncing, mark_syncing);
GC_REG_TRAV(scheme_rt_parameterization, mark_parameterization);
GC_REG_TRAV(scheme_rt_frozen_tramp, mark_frozen_tramp);
}
END_XFORM_SKIP;