thread local variables

[Russ McManus <russell.mcmanus@gs.com>]

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