From 048e8df60fcce0a4e3a093beca12e21458047bd4 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 22 Feb 2016 13:36:31 -0800 Subject: [PATCH] Eliminate uses of fluid-let in the runtime system. This is preparation for redefining fluid-let to call let-fluid. --- src/runtime/dynamic.scm | 150 ++++++++++++++++++----------------- src/runtime/thread.scm | 168 +++++++++++++++++++++------------------- 2 files changed, 165 insertions(+), 153 deletions(-) diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm index 8f27f640f..a7b9a0b04 100644 --- a/src/runtime/dynamic.scm +++ b/src/runtime/dynamic.scm @@ -29,117 +29,121 @@ USA. (declare (usual-integrations)) - ;; 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)))))) ;;;; 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 diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 744a382e6..e27db6499 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -173,7 +173,7 @@ USA. (add-to-population! thread-population thread) (thread-running thread) thread)) - + (define-integrable (without-interrupts thunk) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) (let ((value (thunk))) @@ -212,16 +212,26 @@ USA. (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)) @@ -294,7 +304,7 @@ USA. (begin (set! last-running-thread #f) (wait-for-io)))) - + (define (run-thread thread) (let ((continuation (thread/continuation thread)) (fp-env (thread/floating-point-environment thread))) @@ -311,7 +321,7 @@ USA. (handle-thread-events thread) (set-thread/block-events?! thread #f))) (%maybe-toggle-thread-timer)) - + (define (suspend-current-thread) (without-interrupts %suspend-current-thread)) @@ -417,7 +427,7 @@ USA. (- (system-times/real end) (system-times/real start)))) (set-thread/start-times! thread #f)))))) - + (define (yield-current-thread) (without-interrupts (lambda () @@ -542,6 +552,34 @@ USA. 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))))))) + (define (wait-for-io) (%maybe-toggle-thread-timer #f) (let ((catch-errors @@ -572,7 +610,7 @@ USA. (run-thread thread) (%maybe-toggle-thread-timer)) (wait-for-io)))))) - + (define (signal-select-result result) (cond ((vector? result) (signal-io-thread-events (vector-ref result 0) @@ -648,6 +686,36 @@ USA. (%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)) + (define (deregister-io-thread-event registration) (if (and (pair? registration) (eq? (car registration) 'DEREGISTER-PERMANENT-IO-EVENT)) @@ -711,41 +779,11 @@ USA. (else (dloop (dentry/next dentry))))) (%maybe-toggle-thread-timer)) - -(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))) - + (define (%deregister-io-thread-events thread) (let loop ((dentry io-registrations) (tentries '())) (if (not dentry) @@ -765,7 +803,7 @@ USA. (define (guarantee-select-mode mode procedure) (if (not (memq mode '(READ WRITE READ-WRITE))) (error:wrong-type-argument mode "select mode" procedure))) - + (define (signal-io-thread-events n vfd vmode) (let ((search (lambda (descriptor predicate) @@ -802,34 +840,6 @@ USA. (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))))))) ;;;; Events @@ -1156,7 +1166,7 @@ USA. (define (thread-mutex-owner mutex) (guarantee-thread-mutex mutex 'THREAD-MUTEX-OWNER) (thread-mutex/owner mutex)) - + (define (lock-thread-mutex mutex) (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX) (without-interrupts @@ -1247,9 +1257,7 @@ USA. (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))))) @@ -1339,7 +1347,7 @@ USA. (condition-accessor condition-type:thread-deadlock 'OPERATOR)) (set! thread-deadlock/operand (condition-accessor condition-type:thread-deadlock 'OPERAND)) - + (set! condition-type:thread-detached (make-condition-type 'THREAD-DETACHED condition-type:thread-control-error -- 2.25.1