(declare (usual-integrations))
\f
-
;; The current thread's fluid and parameter bindings.
(define bindings '())
+(define (apply-bindings new-bindings thunk)
+ (let ((swap!
+ (lambda ()
+ (set! bindings (set! new-bindings (set! bindings)))
+ unspecific)))
+ (shallow-fluid-bind swap! thunk swap!)))
+
;;;; Fluids
(define-structure fluid
value)
-(define (guarantee-fluid f operator)
- (if (not (fluid? f))
- (error:wrong-type-argument f "a fluid" operator)))
+(define-guarantee fluid "fluid")
(define (fluid f)
- (guarantee-fluid f 'FLUID)
+ (guarantee-fluid f 'fluid)
(let ((entry (assq f bindings)))
- (if entry (cdr entry) (fluid-value f))))
+ (if entry
+ (cdr entry)
+ (fluid-value f))))
(define (set-fluid! f val)
- (guarantee-fluid f 'SET-FLUID!)
+ (guarantee-fluid f 'set-fluid!)
(let ((entry (assq f bindings)))
- (if entry (set-cdr! entry val) (set-fluid-value! f val))))
+ (if entry
+ (set-cdr! entry val)
+ (set-fluid-value! f val))))
(define (let-fluid fluid value thunk)
- (guarantee-fluid fluid 'LET-FLUID)
- (guarantee-thunk thunk 'LET-FLUID)
- (fluid-let ((bindings (cons (cons fluid value) bindings)))
- (thunk)))
+ (guarantee-fluid fluid 'let-fluid)
+ (guarantee-thunk thunk 'let-fluid)
+ (apply-bindings (cons (cons fluid value) bindings)
+ thunk))
(define (let-fluids . args)
- (let loop ((args args)
- (new-bindings '()))
- (if (null? (cdr args))
+ (let loop
+ ((args args)
+ (new-bindings '()))
+ (if (not (pair? args))
+ (error "Ill-formed let-fluids arguments:" args))
+ (if (pair? (cdr args))
(begin
- (guarantee-thunk (car args) 'LET-FLUIDS)
- (fluid-let ((bindings (append! new-bindings bindings)))
- ((car args))))
- (begin
- (guarantee-fluid (car args) 'LET-FLUIDS)
+ (guarantee-fluid (car args) 'let-fluids)
(loop (cddr args)
- (cons (cons (car args) (cadr args)) new-bindings))))))
+ (cons (cons (car args) (cadr args))
+ new-bindings)))
+ (begin
+ (guarantee-thunk (car args) 'let-fluids)
+ (apply-bindings (append! new-bindings bindings)
+ (car args))))))
\f
;;;; Parameters
-(define-structure %parameter
- value converter)
+(define-structure parameter-metadata
+ value
+ converter)
(define (parameter? p)
- (and (entity? p) (%parameter? (entity-extra p))))
+ (and (entity? p)
+ (parameter-metadata? (entity-extra p))))
-(define (guarantee-parameter p operator)
- (if (not (parameter? p))
- (error:wrong-type-argument p "a parameter" operator)))
+(define-guarantee parameter "parameter")
(define (make-parameter init #!optional converter)
- (if (not (default-object? converter))
- (guarantee-procedure-of-arity converter 1 'MAKE-PARAMETER))
- (make-entity (lambda (self)
- (let ((entry (assq self bindings)))
- (if entry
- (cdr entry)
- (%parameter-value (entity-extra self)))))
- (make-%parameter (if (default-object? converter)
- init
- (converter init))
- (if (default-object? converter)
- identity-procedure
- converter))))
+ (let ((converter
+ (if (default-object? converter)
+ identity-procedure
+ (begin
+ (guarantee-procedure-of-arity converter 1 'make-parameter)
+ converter))))
+ (make-entity (lambda (self)
+ (let ((entry (assq self bindings)))
+ (if entry
+ (cdr entry)
+ (parameter-metadata-value (entity-extra self)))))
+ (make-parameter-metadata (converter init)
+ converter))))
(define (set-parameter! p v)
- (guarantee-parameter p 'PARAMETER-SET!)
- (let ((%p (entity-extra p)))
- (let ((%v ((%parameter-converter %p) v))
- (entry (assq p bindings)))
+ (let ((metadata (entity-extra p)))
+ (let ((entry (assq p bindings))
+ (converted ((parameter-metadata-converter metadata) v)))
(if entry
- (set-cdr! entry %v)
- (set-%parameter-value! %p %v)))))
+ (set-cdr! entry converted)
+ (set-parameter-metadata-value! metadata converted)))))
(define (parameter-converter p)
- (%parameter-converter (entity-extra p)))
+ (parameter-metadata-converter (entity-extra p)))
(define-syntax parameterize
(syntax-rules ()
- ((_ ((PARAM VALUE) BINDING ...) BODY ...)
- (parameterize-helper ((PARAM VALUE) BINDING ...) () BODY ...))))
+ ((_ ((param value) binding ...) body ...)
+ (parameterize-helper ((param value) binding ...) () body ...))))
(define-syntax parameterize-helper
(syntax-rules ()
- ((_ ((PARAM VALUE) BINDING ...) (EXTENSION ...) BODY ...)
- (parameterize-helper (BINDING ...)
- ((cons PARAM VALUE) EXTENSION ...)
- BODY ...))
- ((_ () (EXTENSION ...) BODY ...)
- (parameterize* (list EXTENSION ...) (lambda () BODY ...)))))
+ ((_ ((param value) binding ...) (extension ...) body ...)
+ (parameterize-helper (binding ...)
+ ((cons param value) extension ...)
+ body ...))
+ ((_ () (extension ...) body ...)
+ (parameterize* (list extension ...)
+ (lambda () body ...)))))
(define (parameterize* new-bindings thunk)
- (fluid-let
- ((bindings
- (let loop ((new new-bindings))
- (if (null? new)
- bindings
- (if (and (pair? new)
- (pair? (car new)))
- (let ((p (caar new))
- (v (cdar new)))
- (cons (if (parameter? p)
- (cons p ((parameter-converter p) v))
- (let ((p* (error:wrong-type-argument
- p "parameter" 'parameterize*)))
- (cons p* ((parameter-converter p*) v))))
- (loop (cdr new))))
- (error:wrong-type-argument
- new-bindings "alist" 'parameterize*))))))
- (thunk)))
\ No newline at end of file
+ (guarantee-alist new-bindings 'parameterize*)
+ (apply-bindings
+ (append! (map (lambda (p)
+ (let ((parameter (car p))
+ (value (cdr p)))
+ (cons parameter
+ ((parameter-converter parameter) value))))
+ new-bindings)
+ bindings)
+ thunk))
\ No newline at end of file
(add-to-population! thread-population thread)
(thread-running thread)
thread))
-
+\f
(define-integrable (without-interrupts thunk)
(let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(let ((value (thunk)))
(lambda (return)
(%within-continuation root-continuation #t
(lambda ()
- (fluid-let ((state-space:local (make-state-space)))
- (call-with-current-continuation
- (lambda (continuation)
- (let ((thread (make-thread continuation)))
- (%within-continuation (let ((k return)) (set! return #f) k)
- #t
- (lambda () thread)))))
- (set-interrupt-enables! interrupt-mask/all)
- (exit-current-thread
- (with-create-thread-continuation root-continuation thunk)))))))))
+ (call-with-new-local-state-space
+ (lambda ()
+ (call-with-current-continuation
+ (lambda (continuation)
+ (let ((thread (make-thread continuation)))
+ (%within-continuation (let ((k return)) (set! return #f) k)
+ #t
+ (lambda () thread)))))
+ (set-interrupt-enables! interrupt-mask/all)
+ (exit-current-thread
+ (with-create-thread-continuation root-continuation
+ thunk))))))))))
+
+(define (call-with-new-local-state-space thunk)
+ (let ((temp (make-state-space)))
+ (let ((swap!
+ (lambda ()
+ (set! state-space:local (set! temp (set! state-space:local)))
+ unspecific)))
+ (shallow-fluid-bind swap! thunk swap!))))
(define (create-thread-continuation)
(fluid root-continuation-default))
(begin
(set! last-running-thread #f)
(wait-for-io))))
-\f
+
(define (run-thread thread)
(let ((continuation (thread/continuation thread))
(fp-env (thread/floating-point-environment thread)))
(handle-thread-events thread)
(set-thread/block-events?! thread #f)))
(%maybe-toggle-thread-timer))
-
+\f
(define (suspend-current-thread)
(without-interrupts %suspend-current-thread))
(- (system-times/real end)
(system-times/real start))))
(set-thread/start-times! thread #f))))))
-
+\f
(define (yield-current-thread)
(without-interrupts
(lambda ()
prev
next)
+(define (delete-tentry! tentry)
+ (let ((dentry (tentry/dentry tentry))
+ (prev (tentry/prev tentry))
+ (next (tentry/next tentry)))
+ (set-tentry/dentry! tentry #f)
+ (set-tentry/thread! tentry #f)
+ (set-tentry/event! tentry #f)
+ (set-tentry/prev! tentry #f)
+ (set-tentry/next! tentry #f)
+ (if prev
+ (set-tentry/next! prev next)
+ (set-dentry/first-tentry! dentry next))
+ (if next
+ (set-tentry/prev! next prev)
+ (set-dentry/last-tentry! dentry prev))
+ (if (not (or prev next))
+ (begin
+ (remove-from-select-registry! io-registry
+ (dentry/descriptor dentry)
+ (dentry/mode dentry))
+ (let ((prev (dentry/prev dentry))
+ (next (dentry/next dentry)))
+ (if prev
+ (set-dentry/next! prev next)
+ (set! io-registrations next))
+ (if next
+ (set-dentry/prev! next prev)))))))
+\f
(define (wait-for-io)
(%maybe-toggle-thread-timer #f)
(let ((catch-errors
(run-thread thread)
(%maybe-toggle-thread-timer))
(wait-for-io))))))
-\f
+
(define (signal-select-result result)
(cond ((vector? result)
(signal-io-thread-events (vector-ref result 0)
(%maybe-toggle-thread-timer)
registration))))
+(define (%register-io-thread-event descriptor mode thread event)
+ (let ((tentry (make-tentry thread event)))
+ (let loop ((dentry io-registrations))
+ (cond ((not dentry)
+ (let ((dentry
+ (make-dentry descriptor
+ mode
+ tentry
+ tentry
+ #f
+ io-registrations)))
+ (set-tentry/dentry! tentry dentry)
+ (set-tentry/prev! tentry #f)
+ (set-tentry/next! tentry #f)
+ (if io-registrations
+ (set-dentry/prev! io-registrations dentry))
+ (set! io-registrations dentry)
+ (add-to-select-registry! io-registry descriptor mode)))
+ ((and (eqv? descriptor (dentry/descriptor dentry))
+ (eq? mode (dentry/mode dentry)))
+ (set-tentry/dentry! tentry dentry)
+ (let ((prev (dentry/last-tentry dentry)))
+ (set-tentry/prev! tentry prev)
+ (set-tentry/next! tentry #f)
+ (set-dentry/last-tentry! dentry tentry)
+ (set-tentry/next! prev tentry)))
+ (else
+ (loop (dentry/next dentry)))))
+ tentry))
+\f
(define (deregister-io-thread-event registration)
(if (and (pair? registration)
(eq? (car registration) 'DEREGISTER-PERMANENT-IO-EVENT))
(else
(dloop (dentry/next dentry)))))
(%maybe-toggle-thread-timer))
-\f
-(define (%register-io-thread-event descriptor mode thread event)
- (let ((tentry (make-tentry thread event)))
- (let loop ((dentry io-registrations))
- (cond ((not dentry)
- (let ((dentry
- (make-dentry descriptor
- mode
- tentry
- tentry
- #f
- io-registrations)))
- (set-tentry/dentry! tentry dentry)
- (set-tentry/prev! tentry #f)
- (set-tentry/next! tentry #f)
- (if io-registrations
- (set-dentry/prev! io-registrations dentry))
- (set! io-registrations dentry)
- (add-to-select-registry! io-registry descriptor mode)))
- ((and (eqv? descriptor (dentry/descriptor dentry))
- (eq? mode (dentry/mode dentry)))
- (set-tentry/dentry! tentry dentry)
- (let ((prev (dentry/last-tentry dentry)))
- (set-tentry/prev! tentry prev)
- (set-tentry/next! tentry #f)
- (set-dentry/last-tentry! dentry tentry)
- (set-tentry/next! prev tentry)))
- (else
- (loop (dentry/next dentry)))))
- tentry))
(define (%deregister-io-thread-event tentry)
(if (tentry/dentry tentry)
(delete-tentry! tentry)))
-
+\f
(define (%deregister-io-thread-events thread)
(let loop ((dentry io-registrations) (tentries '()))
(if (not dentry)
(define (guarantee-select-mode mode procedure)
(if (not (memq mode '(READ WRITE READ-WRITE)))
(error:wrong-type-argument mode "select mode" procedure)))
-\f
+
(define (signal-io-thread-events n vfd vmode)
(let ((search
(lambda (descriptor predicate)
(do ((events events (cdr events)))
((not (pair? events)))
(%signal-thread-event (caar events) (cdar events)))))))
-
-(define (delete-tentry! tentry)
- (let ((dentry (tentry/dentry tentry))
- (prev (tentry/prev tentry))
- (next (tentry/next tentry)))
- (set-tentry/dentry! tentry #f)
- (set-tentry/thread! tentry #f)
- (set-tentry/event! tentry #f)
- (set-tentry/prev! tentry #f)
- (set-tentry/next! tentry #f)
- (if prev
- (set-tentry/next! prev next)
- (set-dentry/first-tentry! dentry next))
- (if next
- (set-tentry/prev! next prev)
- (set-dentry/last-tentry! dentry prev))
- (if (not (or prev next))
- (begin
- (remove-from-select-registry! io-registry
- (dentry/descriptor dentry)
- (dentry/mode dentry))
- (let ((prev (dentry/prev dentry))
- (next (dentry/next dentry)))
- (if prev
- (set-dentry/next! prev next)
- (set! io-registrations next))
- (if next
- (set-dentry/prev! next prev)))))))
\f
;;;; Events
(define (thread-mutex-owner mutex)
(guarantee-thread-mutex mutex 'THREAD-MUTEX-OWNER)
(thread-mutex/owner mutex))
-
+\f
(define (lock-thread-mutex mutex)
(guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
(without-interrupts
(lambda ()
(let ((owner (thread-mutex/owner mutex)))
(if (eq? owner thread)
- (begin
- (set! grabbed-lock? #f)
- unspecific)
+ (set! grabbed-lock? #f)
(begin
(set! grabbed-lock? #t)
(%lock-thread-mutex mutex thread owner)))))
(condition-accessor condition-type:thread-deadlock 'OPERATOR))
(set! thread-deadlock/operand
(condition-accessor condition-type:thread-deadlock 'OPERAND))
-
+\f
(set! condition-type:thread-detached
(make-condition-type 'THREAD-DETACHED
condition-type:thread-control-error
projects / mit-scheme.git / commitdiff