(define-structure (event-distributor
(constructor make-event-distributor ())
(conc-name event-distributor/))
- (events (make-queue))
+ (events (make-serial-queue))
(lock false)
(receivers '()))
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! primitive-gc-daemons (make-queue))
+ (set! primitive-gc-daemons (make-serial-queue))
(set! trigger-primitive-gc-daemons! (make-trigger primitive-gc-daemons))
(set! add-primitive-gc-daemon! (make-adder primitive-gc-daemons))
- (set! gc-daemons (make-queue))
+ (set! add-primitive-gc-daemon!/unsafe
+ (make-adder/unsafe primitive-gc-daemons))
+ (set! gc-daemons (make-serial-queue))
(set! trigger-gc-daemons! (make-trigger gc-daemons))
(set! add-gc-daemon! (make-adder gc-daemons))
- (set! secondary-gc-daemons (make-queue))
+ (set! add-gc-daemon!/unsafe (make-adder/unsafe gc-daemons))
+ (set! secondary-gc-daemons (make-serial-queue))
(set! trigger-secondary-gc-daemons! (make-trigger secondary-gc-daemons))
(set! add-secondary-gc-daemon! (make-adder secondary-gc-daemons))
+ (set! add-secondary-gc-daemon!/unsafe
+ (make-adder/unsafe secondary-gc-daemons))
(let ((fixed-objects ((ucode-primitive get-fixed-objects-vector))))
(vector-set! fixed-objects #x0B trigger-primitive-gc-daemons!)
((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
(define primitive-gc-daemons)
(define trigger-primitive-gc-daemons!)
(define add-primitive-gc-daemon!)
+(define add-primitive-gc-daemon!/unsafe)
;;; GC-DAEMONS are executed after each GC from an interrupt handler.
;;; This interrupt handler has lower priority than the GC interrupt,
(define gc-daemons)
(define trigger-gc-daemons!)
(define add-gc-daemon!)
+(define add-gc-daemon!/unsafe)
(define (add-gc-daemon!/no-restore daemon)
(add-gc-daemon!
(lambda ()
(define secondary-gc-daemons)
(define trigger-secondary-gc-daemons!)
(define add-secondary-gc-daemon!)
+(define add-secondary-gc-daemon!/unsafe)
(define (make-trigger daemons)
(lambda ()
(lambda (daemon)
(enqueue! daemons daemon)))
+(define (make-adder/unsafe daemons)
+ (lambda (daemon)
+ (enqueue!/unsafe daemons daemon)))
+
(define (gc-clean #!optional threshold)
(let ((threshold
(cond ((default-object? threshold) 100)
(define (initialize-package!)
(set! population-of-populations (list population-tag (make-thread-mutex)))
- (add-secondary-gc-daemon! clean-all-populations!))
+ (add-secondary-gc-daemon!/unsafe clean-all-populations!))
(define (initialize-unparser!)
(unparser/set-tagged-pair-method! population-tag
\f
(define (initialize-package!)
(set! population-of-1d-tables (make-serial-population/unsafe))
- (add-secondary-gc-daemon! clean-1d-tables!))
+ (add-secondary-gc-daemon!/unsafe clean-1d-tables!))
(define (initialize-unparser!)
(unparser/set-tagged-pair-method! 1d-table-tag
(declare (usual-integrations))
\f
(define-integrable (make-queue)
- (cons '() '()))
+ (cons* #f '() '()))
+
+(define-integrable (make-serial-queue)
+ (cons* (make-thread-mutex) '() '()))
(define-integrable (queue-empty? queue)
- (not (pair? (car queue))))
+ (not (pair? (cadr queue))))
(define-integrable (queued?/unsafe queue item)
- (memq item (car queue)))
+ (memq item (cadr queue)))
(define (enqueue!/unsafe queue object)
(let ((next (cons object '())))
- (if (pair? (cdr queue))
- (set-cdr! (cdr queue) next)
- (set-car! queue next))
- (set-cdr! queue next)
+ (if (pair? (cddr queue))
+ (set-cdr! (cddr queue) next)
+ (set-car! (cdr queue) next))
+ (set-cdr! (cdr queue) next)
unspecific))
(define (dequeue!/unsafe queue)
- (let ((next (car queue)))
+ (let ((next (cadr queue)))
(if (not (pair? next))
(error "Attempt to dequeue from empty queue"))
(if (pair? (cdr next))
- (set-car! queue (cdr next))
+ (set-car! (cdr queue) (cdr next))
(begin
- (set-car! queue '())
- (set-cdr! queue '())))
+ (set-car! (cdr queue) '())
+ (set-cdr! (cdr queue) '())))
(car next)))
(define (queue-map!/unsafe queue procedure)
(loop)))))
(define-integrable (queue->list/unsafe queue)
- (car queue))
+ (cadr queue))
+
+;;; Safe versions of the above operations (when used on a serializing
+;;; queue).
-;;; Safe (interrupt locked) versions of the above operations.
+(define-integrable (with-queue-lock queue thunk)
+ (let ((mutex (car queue)))
+ (if mutex
+ (with-thread-mutex-lock mutex
+ (lambda ()
+ (without-interruption thunk)))
+ (without-interruption thunk))))
(define-integrable (queued? queue item)
- (without-interrupts (lambda () (queued?/unsafe queue item))))
+ (with-queue-lock queue (lambda () (queued?/unsafe queue item))))
(define-integrable (enqueue! queue object)
- (without-interrupts (lambda () (enqueue!/unsafe queue object))))
+ (with-queue-lock queue (lambda () (enqueue!/unsafe queue object))))
(define-integrable (dequeue! queue)
- (without-interrupts (lambda () (dequeue!/unsafe queue))))
+ (with-queue-lock queue (lambda () (dequeue!/unsafe queue))))
(define (queue-map! queue procedure)
(let ((empty (list 'EMPTY)))
(let loop ()
(let ((item
- (without-interrupts
+ (with-queue-lock queue
(lambda ()
(if (queue-empty? queue)
empty
(loop)))))))
(define (queue->list queue)
- (without-interrupts
+ (with-queue-lock queue
(lambda ()
(list-copy (queue->list/unsafe queue)))))
\ No newline at end of file
(condition #f read-only #t)
(reader-history (make-repl-history repl-reader-history-size))
(printer-history (make-repl-history repl-printer-history-size))
- (input-queue (make-queue) read-only #t))
+ (input-queue (make-serial-queue) read-only #t))
(define (repl? object)
(and (cmdl? object)
(parent (runtime))
(export ()
make-queue
+ make-serial-queue
queue-empty?
queued?/unsafe
enqueue!/unsafe
(import (runtime population)
make-serial-population/unsafe
add-to-population!/unsafe)
+ (import (runtime gc-daemons)
+ add-secondary-gc-daemon!/unsafe)
(initialization (initialize-package!)))
(define-package (runtime 2d-property)
(define-package (runtime population)
(files "poplat")
(parent (runtime))
+ (import (runtime gc-daemons)
+ add-secondary-gc-daemon!/unsafe)
(export ()
add-to-population!
empty-population!
projects / mit-scheme.git / commitdiff