;; Caseful symbol or list, e.g. (* |GtkWidget|).
return-type
- ;; Alist of parameter names * types, e.g. ((widget (* |GtkWidget|))...)
+ ;; Alist of parameter names * types, e.g. ((widget . (* |GtkWidget|))...)
parameters
;; Filename from which the EXTERN declaration was read.
(define-integrable (c-poke-bytes alien offset count buffer start)
((ucode-primitive c-poke-bytes 5) alien offset count buffer start))
+(define-integrable (processor-id)
+ (if enable-smp?
+ ((ucode-primitive smp-id 0))
+ 0))
+
(define (c-enum-name value enum-name constants)
enum-name
(let loop ((consts constants))
args)
(without-interrupts
(lambda ()
- (call-alien* alien-function args))))
-
-(define (call-alien* alien-function args)
- (let ((old-top calloutback-stack))
- (%if-tracing
- (outf-error ";"(tindent)"=> "alien-function" "args"\n")
- (set! calloutback-stack (cons (cons* alien-function args) old-top)))
- (let ((value (apply (ucode-primitive c-call -1) alien-function args)))
- (%if-tracing
- (%assert (eq? old-top (cdr calloutback-stack))
- "call-alien: freak stack "calloutback-stack"\n")
- (set! calloutback-stack old-top)
- (outf-error ";"(tindent)"<= "value"\n"))
- value)))
+ (let* ((id (processor-id))
+ (old-top (vector-ref calloutback-stacks id)))
+ (%trace ";"(tindent id)"=> "alien-function" "args)
+ (vector-set! calloutback-stacks id
+ (cons (cons alien-function args) old-top))
+ (let ((value (apply (ucode-primitive c-call -1) alien-function args)))
+ (%assert (eq? id (processor-id))
+ "call-alien: slipped processors")
+ (%assert (eq? old-top (cdr (vector-ref calloutback-stacks id)))
+ "call-alien: freak stack "(vector-ref calloutback-stacks id))
+ (vector-set! calloutback-stacks id old-top)
+ (%trace ";"(tindent id)"<= "value)
+ value)))))
\f
;;; Malloc/Free
;; Weak alist of: ( malloc alien X copy for c-free )...
(define malloced-aliens '())
-
-(define (free-malloced-aliens)
- (let loop ((aliens malloced-aliens)
- (prev #f))
- (if (pair? aliens)
- (if (weak-pair/car? (car aliens))
- (loop (cdr aliens) aliens)
- (let ((copy (weak-cdr (car aliens)))
- (next (cdr aliens)))
- (if prev
- (set-cdr! prev next)
- (set! malloced-aliens next))
- (if (not (alien-null? copy))
- (begin
- ((ucode-primitive c-free 1) copy)
- (alien-null! copy)))
- (loop next prev))))))
+(define malloced-aliens-mutex)
(define (reset-malloced-aliens!)
+ (set! malloced-aliens-mutex (make-thread-mutex))
(let loop ((aliens malloced-aliens))
(if (pair? aliens)
(let ((alien (weak-car (car aliens)))
(loop (cdr aliens)))))
(set! malloced-aliens '()))
+(define (free-malloced-aliens)
+ (with-thread-mutex-locked malloced-aliens-mutex
+ (lambda ()
+ (let loop ((aliens malloced-aliens)
+ (prev #f))
+ (if (pair? aliens)
+ (if (weak-pair/car? (car aliens))
+ (loop (cdr aliens) aliens)
+ (let ((copy (weak-cdr (car aliens)))
+ (next (cdr aliens)))
+ (if prev
+ (set-cdr! prev next)
+ (set! malloced-aliens next))
+ (if (not (alien-null? copy))
+ (begin
+ ((ucode-primitive c-free 1) copy)
+ (alien-null! copy)))
+ (loop next prev))))))))
+
(define (make-alien-to-free ctype init)
;; Register BEFORE initializing (allocating).
(let ((alien (make-alien ctype)))
(let ((copy (make-alien ctype)))
(let ((entry (weak-cons alien copy)))
- (without-interrupts
+ (with-thread-mutex-locked malloced-aliens-mutex
(lambda ()
(set! malloced-aliens (cons entry malloced-aliens)))))
(init copy)
(if (not weak)
(warn "Cannot free an alien that was not malloced:" alien)
(let ((copy (weak-cdr weak)))
- (without-interrupts
+ (with-thread-mutex-locked malloced-aliens-mutex
(lambda ()
(if (not (alien-null? alien))
(begin
;;; Callback support
(define registered-callbacks)
+(define registered-callbacks-mutex)
(define first-free-id)
(define (reset-callbacks!)
(set! registered-callbacks (make-vector 100 #f))
+ (set! registered-callbacks-mutex (make-thread-mutex))
(set! first-free-id 1))
(define (register-c-callback procedure)
(if (not (procedure? procedure))
(error:wrong-type-argument procedure "a procedure" 'register-c-callback))
- (without-interrupts
+ (with-thread-mutex-locked registered-callbacks-mutex
(lambda ()
(let ((id first-free-id))
(set! first-free-id (next-free-id (1+ id)))
(else (next-id (1+ id)))))))
(define (de-register-c-callback id)
- (vector-set! registered-callbacks id #f)
- ;; Uncomment to recycle ids.
- ;;(if (< id first-free-id)
- ;; (set! first-free-id id))
- )
+ (with-thread-mutex-locked registered-callbacks-mutex
+ (lambda ()
+ (vector-set! registered-callbacks id #f)
+ ;; Uncomment to recycle ids.
+ (if (< id first-free-id)
+ (set! first-free-id id))
+ )))
(define (normalize-aliens! args)
;; Any vectors among ARGS are assumed to be freshly-consed aliens
;; by a callback trampoline. The callout should have already masked
;; all but the GC interrupts.
+ (%assert (fix:= 0 (fix:andc (get-interrupt-enables) interrupt-mask/gc-ok))
+ "callback-handler: can be interrupted")
(if (not (< id (vector-length registered-callbacks)))
(error:bad-range-argument id 'apply-callback))
(let ((procedure (vector-ref registered-callbacks id)))
(if (not procedure)
(error:bad-range-argument id 'apply-callback))
(normalize-aliens! args)
- (let ((old-top calloutback-stack))
- (%if-tracing
- (outf-error ";"(tindent)"=>> "procedure" "args"\n")
- (set! calloutback-stack (cons (cons procedure args) old-top)))
+ (let* ((id (processor-id))
+ (old-top (vector-ref calloutback-stacks id)))
+ (%trace ";"(tindent id)"=>> "procedure" "args)
+ (vector-set! calloutback-stacks id (cons (cons procedure args) old-top))
(let ((value (apply-callback-proc procedure args)))
- (%if-tracing
- (%assert (and (pair? calloutback-stack)
- (eq? old-top (cdr calloutback-stack)))
- "callback-handler: freak stack "calloutback-stack"\n")
- (set! calloutback-stack old-top)
- (outf-error ";"(tindent)"<<= "value"\n"))
+ (%assert (eq? id (processor-id))
+ "callback-handler: slipped processors")
+ (%assert (and (pair? (vector-ref calloutback-stacks id))
+ (eq? old-top (cdr (vector-ref calloutback-stacks id))))
+ "callback-handler: freak stack "
+ (vector-ref calloutback-stacks id))
+ (vector-set! calloutback-stacks id old-top)
+ (%trace ";"(tindent id)"<<= "value)
value))))
(define (apply-callback-proc procedure args)
kernel)))))
\f
-(define calloutback-stack '())
+(define calloutback-stacks)
(define %trace? #f)
(reset-callbacks!)
(set! %radix (if (fix:fixnum? #x100000000) #x100000000 #x10000))
(set! %trace? #f)
- (set! calloutback-stack '()))
+ (set! calloutback-stacks (make-vector processor-count '())))
(define (initialize-package!)
(reset-package!)
(add-gc-daemon! free-malloced-aliens)
unspecific)
-(define-syntax %if-tracing
- (syntax-rules ()
- ((_ BODY ...)
- (if %trace?
- (begin BODY ...)))))
-
(define-syntax %assert
(syntax-rules ()
((_ TEST MSG ...)
(syntax-rules ()
((_ MSG ...)
(if %trace?
- (outf-error MSG ...)))))
+ (outf-error MSG ... "\n")))))
-(define (tindent)
- (make-string (* 2 (length calloutback-stack)) #\space))
\ No newline at end of file
+(define (tindent id)
+ (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space))
\ No newline at end of file
projects / mit-scheme.git / commitdiff