This is the mail archive of the guile@cygnus.com mailing list for the guile project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
I've been reading up on MzScheme's handling of thread local variables, and they have a very neat system. You can read all about it, including the motivation, by starting here: http://www.cs.rice.edu/CS/PLT/packages/doc/mzscheme/node99.htm I've already whipped up 75% of this interface, and I'd like to get feedback from those who use threads in guile about whether the interface would be useful. To take full advantage of the system, there has to be a hook into thread creation that allows for the copying of parameters into the new thread's context. The really neat part of the system is that the user can specify which parameters are shared between threads, and which are not, all using an intuitive syntax. I think that they've really given this design a lot of thought, and it shows. The design allows for easy backward compatibility with procedures like (current-output-port) and friends. -russ Here is a rudimentary implementation of parameters for guile (danger only lightly tested code ahead): #!/opt/guile/bin/guile -s !# (define-module (ice-9 parameter) :use-module (ice-9 common-list) :use-module (ice-9 slib) :use-module (ice-9 threads)) (require 'struct) (require 'pretty-print) ;;; end-header ;;;; This page of code implements parameters. ;;; If two parameters are shared, then they share a pd. (define-record pd (guard mutex value)) ;;; Marker to tell a paremter to return it's pd. This magic valid is ;;; hidden to all code outside this module, so it's difficult to ;;; spoof. (define *return-pd* (cons 'return-pd '())) (define (parameter? p) "This implementation allows false positives, but I can't think of a nice way to do this right now. object-properties might work, or I could send a message to the parameter procedure, and capture errors to return #f if necessary, or perhaps a weak hash table of all the parameters that have ever been created would work." (procedure? p)) (define (make-parameter-from-pd pd) "A parameter is a procedure that returns a value when applied with no arguments. When applied with one argument, the parameter's value is updated to the argument." (lambda args (if (null? args) (pd->value pd) (let ((new-v (car args)) (rest (cdr args))) (if (not (null? rest)) (error "wrong number of args to parameter procedure")) (if (eq? new-v *return-pd*) pd (begin (lock-mutex (pd->mutex pd)) (set-pd-value! pd ((pd->guard pd) new-v)) (unlock-mutex (pd->mutex pd)) new-v)))))) (define (make-parameter v . maybe-guard) (make-parameter-from-pd (make-pd (if (null? maybe-guard) (lambda (new-v) new-v) (car maybe-guard)) (make-mutex) v))) (define (clone-parameter p share?) (let ((pd (p *return-pd*))) (make-parameter-from-pd (if share? pd (make-pd (pd->guard pd) (make-mutex) (pd->value pd)))))) (define (parameter-procedure=? a b) "Two parameters procedures always modify the same parameter is they share the same pd." (eq? (a *return-pd*) (b *return-pd*))) ;;;; This page of code implements parameterizations, which are ;;;; collections of parameters. Each thread should have it's own ;;;; collection, which means that the implementation will use fluids. ;;;; ;;;; Parameterizations are implemented as a cons pair ;;;; whose car is the unique value *parameterization-tag*, and whose ;;;; cdr is an eq? hash table associating parameter names with parameters. (define *parameterization-tag* (cons '*parameterization-tag* '())) (define (parameterization? p) (and (pair? p) (eq? (car p) *parameterization-tag*))) (define *hash-table-size* 20) (define (make-empty-parameterization) (cons *parameterization-tag* (make-hash-table *hash-table-size*))) (define (parameterization-set! parameterization name parameter) (hashq-set! (cdr parameterization) name parameter)) (define (parameterization-ref parameterization name) (hashq-ref (cdr parameterization) name)) (define (parameterization-for-each proc parameterization) (do ((i 0 (+ 1 i)) (ht (cdr parameterization))) ((= i (vector-length ht)) #t) (for-each (lambda (pair) (proc (car pair) (cdr pair))) (vector-ref ht i)))) (define *current-parameterization* (let ((f (make-fluid))) (fluid-set! f (make-empty-parameterization)) f)) (define (make-parameterization . maybe-base-parameterization) "Returns a new parameterization, copying its initial parameter values from the parameterization MAYBE-BASE-P. If MAYBE-BASE-P is not provided, the currency parameterization is used." (let ((base-parameterization (if (null? maybe-base-parameterization) (current-parameterization) (car maybe-base-p))) (new-parameterization (make-empty-parameterization))) (parameterization-for-each (lambda (name parameter) (parameterization-set! new-parameterization name (clone-parameter parameter #f))) ;; no sharing by default base-parameterization))) (define (current-parameterization . args) (if (null? args) (fluid-ref *current-parameterization*) (let ((new-parameterization (car args))) (if (not (null? (cdr args))) (error "wrong number of args to current-parameterization")) (fluid-set! *current-parameterization* new-parameterization)))) ; (parameterize ((error-handler (lambda (err-tag . args) blah)) ; (current-ui some-ui)) ; (expr1) ; (expr2)) ; should expand into ; (let ((%%gensym24 (make-fluid)) ; (%%gensym25 (make-fluid))) ; (dynamic-wind ; (lambda () ; (begin (fluid-set! %%gensym24 (error-handler)) ; (error-handler (lambda (err-tag . args) blah))) ; (begin (fluid-set! %%gensym25 (current-ui)) ; (current-ui some-ui))) ; (lambda () ; (expr1) ; (expr2)) ; (lambda () ; (error-handler (fluid-ref %%gensym24)) ; (current-ui (fluid-ref %%gensym25))))) (defmacro expand (form) `(pretty-print (macroexpand (quote ,form)))) (defmacro parameterize (pv-list . body) (let* ((name-alist (map (lambda (pv) (list (list-ref pv 0) (list-ref pv 1) (gensym))) pv-list)) (name-list (map car pv-list)) (name->value (lambda (name) (list-ref (assq name name-alist) 1))) (name->gensym (lambda (name) (list-ref (assq name name-alist) 2)))) `(let ,(map (lambda (name) `(,(name->gensym name) (make-fluid))) name-list) (dynamic-wind (lambda () ,@(map (lambda (name) `(begin (fluid-set! ,(name->gensym name) (,name)) (,name ,(name->value name)))) name-list)) (lambda () ,@body) (lambda () ,@(map (lambda (name) `(,name (fluid-ref ,(name->gensym name)))) name-list)))))) (export parameterize) (export make-parameter) (export current-parameterization) (export clone-parameter) -- WAR IS PEACE FREEDOM IS SLAVERY BACKSPACE IS DELETE