101 lines
2.6 KiB
Scheme
101 lines
2.6 KiB
Scheme
|
; Placeholders (single-assignment cells for use with threads)
|
||
|
|
|
||
|
|
(define-record-type :placeholder
|
||
|
|
(really-make-placeholder priority queue value id)
|
||
|
|
placeholder?
|
||
|
|
(priority placeholder-priority set-placeholder-priority!)
|
||
|
|
(queue placeholder-queue set-placeholder-queue!)
|
||
|
|
(value placeholder-value-internal set-placeholder-value!)
|
||
|
|
(id placeholder-id))
|
||
|
|
|
||
|
|
(define-record-discloser :placeholder
|
||
|
|
(lambda (placeholder)
|
||
|
|
(cons 'placeholder
|
||
|
|
(if (placeholder-id placeholder)
|
||
|
|
(list (placeholder-id placeholder))
|
||
|
|
'()))))
|
||
|
|
|
||
|
|
(define-record-type :q-item
|
||
|
|
(make-q-item trans-id cleanup-thunk wrap-proc)
|
||
|
|
q-item?
|
||
|
|
(trans-id q-item-trans-id)
|
||
|
|
(cleanup-thunk q-item-cleanup-thunk)
|
||
|
|
(wrap-proc q-item-wrap-proc))
|
||
|
|
|
||
|
|
(define (clean-and-enqueue! queue value)
|
||
|
|
(clean-queue-head! queue)
|
||
|
|
(enqueue! queue value))
|
||
|
|
|
||
|
|
(define (clean-and-dequeue! queue)
|
||
|
|
(let loop ()
|
||
|
|
(if (queue-empty? queue)
|
||
|
|
#f
|
||
|
|
(let ((front (dequeue! queue)))
|
||
|
|
(if (trans-id-cancelled? (q-item-trans-id front))
|
||
|
|
(loop)
|
||
|
|
front)))))
|
||
|
|
|
||
|
|
(define (clean-queue-head! queue)
|
||
|
|
(let loop ()
|
||
|
|
(if (not (queue-empty? queue))
|
||
|
|
(let ((front (queue-front queue)))
|
||
|
|
(if (trans-id-cancelled? (q-item-trans-id front))
|
||
|
|
(begin
|
||
|
|
(dequeue! queue)
|
||
|
|
(loop)))))))
|
||
|
|
|
||
|
|
(define (make-placeholder . id-option)
|
||
|
|
(really-make-placeholder 0
|
||
|
|
(make-queue)
|
||
|
|
(unspecific)
|
||
|
|
(if (null? id-option)
|
||
|
|
#f
|
||
|
|
(car id-option))))
|
||
|
|
|
||
|
|
(define (placeholder-value-rv placeholder)
|
||
|
|
(make-base
|
||
|
|
(lambda ()
|
||
|
|
(cond
|
||
|
|
((placeholder-queue placeholder)
|
||
|
|
=> (lambda (queue)
|
||
|
|
(make-blocked
|
||
|
|
(lambda (trans-id cleanup-thunk wrap-proc)
|
||
|
|
(clean-and-enqueue! queue
|
||
|
|
(make-q-item trans-id
|
||
|
|
cleanup-thunk
|
||
|
|
wrap-proc))))))
|
||
|
|
(else
|
||
|
|
(let ((priority (placeholder-priority placeholder)))
|
||
|
|
(set-placeholder-priority! placeholder (+ 1 priority))
|
||
|
|
(make-enabled
|
||
|
|
priority
|
||
|
|
(lambda ()
|
||
|
|
(placeholder-value-internal placeholder)))))))))
|
||
|
|
|
||
|
|
(define (placeholder-set! placeholder value)
|
||
|
|
(enter-cr!)
|
||
|
|
(cond
|
||
|
|
((placeholder-queue placeholder)
|
||
|
|
=> (lambda (queue)
|
||
|
|
(set-placeholder-value! placeholder value)
|
||
|
|
(set-placeholder-queue! placeholder #f)
|
||
|
|
(let loop ()
|
||
|
|
(cond
|
||
|
|
((clean-and-dequeue! queue)
|
||
|
|
=> (lambda (q-item)
|
||
|
|
((q-item-cleanup-thunk q-item))
|
||
|
|
(cr-trans-id-wakeup (q-item-trans-id q-item)
|
||
|
|
(cons value
|
||
|
|
(q-item-wrap-proc q-item)))
|
||
|
|
(loop)))))
|
||
|
|
(leave-cr!)
|
||
|
|
(unspecific)))
|
||
|
|
(else
|
||
|
|
(leave-cr!)
|
||
|
|
(error "placeholder is already assigned" placeholder value))))
|
||
|
|
|
||
|
|
(define (placeholder-value placeholder)
|
||
|
|
(sync (placeholder-value-rv placeholder)))
|
||
|
|
|
||
|
|
|
||
|
|
|