scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added thread-cells structure for thread-local cells. 

These can be used (together with fluids) to implement something akin
to PLT's and Chez's parameters for holding thread-local state such as
CWD, syslog channel, etc.
This commit is contained in:
sperber 2001-05-22 14:58:15 +00:00
parent 4d1cc24519
commit 21a8e255eb
13 changed files with 5803 additions and 5510 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
build/filenames.make
View File

@ -1,6 +1,6 @@
#### This file was generated automatically. ####
initial-files = scheme/rts/low.scm scheme/rts/signal.scm scheme/rts/base.scm scheme/rts/util.scm scheme/rts/number.scm scheme/rts/lize.scm scheme/rts/record.scm scheme/rts/jar-defrecord.scm scheme/rts/method.scm scheme/rts/numio.scm scheme/rts/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/big/queue.scm scheme/rts/condition.scm scheme/rts/session.scm scheme/rts/interrupt.scm scheme/rts/wind.scm scheme/rts/template.scm scheme/rts/continuation.scm scheme/rts/exception.scm scheme/rts/thread.scm scheme/rts/sleep.scm scheme/rts/lock.scm scheme/rts/port.scm scheme/rts/current-port.scm scheme/rts/write.scm scheme/rts/read.scm scheme/rts/channel.scm scheme/rts/channel-port.scm scheme/rts/channel-io.scm scheme/big/general-table.scm scheme/rts/population.scm scheme/bcomp/mtype.scm scheme/bcomp/interface.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/cenv.scm scheme/bcomp/thingie.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/rts/env.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/syntax.scm scheme/bcomp/primop.scm scheme/bcomp/ddata.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/rts/eval.scm scheme/env/dispcond.scm scheme/debug/mini-command.scm scheme/rts/scheduler.scm scheme/rts/root-scheduler.scm scheme/rts/init.scm scheme/env/start.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/type.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/bcomp/scan-package.scm scheme/bcomp/optimize.scm scheme/bcomp/comp-package.scm scheme/env/load-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/bcomp/for-reify.scm
initial-files = scheme/rts/low.scm scheme/rts/signal.scm scheme/rts/base.scm scheme/rts/util.scm scheme/rts/number.scm scheme/rts/lize.scm scheme/rts/record.scm scheme/rts/jar-defrecord.scm scheme/rts/method.scm scheme/rts/numio.scm scheme/rts/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/big/queue.scm scheme/rts/condition.scm scheme/rts/session.scm scheme/rts/interrupt.scm scheme/rts/wind.scm scheme/rts/thread-cell.scm scheme/rts/template.scm scheme/rts/continuation.scm scheme/rts/exception.scm scheme/rts/thread.scm scheme/rts/sleep.scm scheme/rts/lock.scm scheme/rts/port.scm scheme/rts/current-port.scm scheme/rts/write.scm scheme/rts/read.scm scheme/rts/channel.scm scheme/rts/channel-port.scm scheme/rts/channel-io.scm scheme/big/general-table.scm scheme/rts/population.scm scheme/bcomp/mtype.scm scheme/bcomp/interface.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/cenv.scm scheme/bcomp/thingie.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/rts/env.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/syntax.scm scheme/bcomp/primop.scm scheme/bcomp/ddata.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/rts/eval.scm scheme/env/dispcond.scm scheme/debug/mini-command.scm scheme/rts/sigevents.scm scheme/rts/scheduler.scm scheme/rts/root-scheduler.scm scheme/rts/init.scm scheme/env/start.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/type.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/bcomp/scan-package.scm scheme/bcomp/optimize.scm scheme/bcomp/comp-package.scm scheme/env/load-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/bcomp/for-reify.scm
usual-files = scheme/opt/analyze.scm scheme/env/disclosers.scm scheme/env/command-level.scm scheme/env/version-info.scm scheme/env/command.scm scheme/env/read-command.scm scheme/env/debuginfo.scm scheme/rts/xnum.scm scheme/rts/bignum.scm scheme/rts/ratnum.scm scheme/rts/recnum.scm scheme/rts/innum.scm scheme/env/basic-command.scm scheme/env/build.scm scheme/env/shadow.scm scheme/env/pedit.scm scheme/env/pacman.scm scheme/rts/time.scm scheme/env/debug.scm scheme/env/inspect.scm scheme/env/disasm.scm

11151
build/initial.debug
View File

File diff suppressed because it is too large Load Diff

BIN
build/initial.image
View File

Binary file not shown.

10
scheme/env/command-level.scm vendored
View File

@ -168,8 +168,11 @@
; that when it is rescheduled after blocking it can be put on the correct
; run queue.
(define (spawn-on-command-level level thunk id)
(let ((thread (make-thread thunk (command-level-dynamic-env level) id)))
(define (spawn-on-command-level level thunk cell-values id)
(let ((thread (make-thread thunk
(command-level-dynamic-env level)
cell-values
id)))
(set-thread-scheduler! thread (command-thread))
(set-thread-data! thread level)
(enqueue-thread! (command-level-queue level) thread)
@ -181,6 +184,7 @@
(define (spawn-repl-thread! level)
(let ((thread (spawn-on-command-level level
(command-level-repl-thunk level)
(empty-cell-values)
'command-loop)))
(set-command-level-repl-thread! level thread)))
@ -353,7 +357,7 @@
(lambda (event args)
(enum-case event-type event
((spawned)
(spawn-on-command-level level (car args) (cadr args))
(spawn-on-command-level level (car args) (cadr args) (caddr args))
#t)
((runnable)
(let* ((thread (car args))

16
scheme/interfaces.scm
View File

@ -390,6 +390,16 @@
really-string->number &really-string->number ;exactness argument
string->integer))
(define-interface thread-cells-interface
(export make-thread-cell
thread-cell-ref
thread-cell-set!))
(define-interface thread-cells-internal-interface
(export get-cell-values
empty-cell-values ; env/command-level.scm
initialize-dynamic-state!))
(define-interface fluids-interface
(export make-fluid
let-fluid
@ -398,13 +408,13 @@
set-fluid!))
(define-interface fluids-internal-interface
(export initialize-dynamic-state!
current-thread
(export current-thread
set-current-thread!
get-dynamic-env ; wind.scm, env/command-level.scm
set-dynamic-env! ; wind.scm
get-dynamic-point ; wind.scm
set-dynamic-point!)) ; wind.scm
set-dynamic-point! ; wind.scm
empty-dynamic-env)) ; thread-cell.scm
(define-interface enumerated-interface
(export (define-enumeration :syntax)

1
scheme/more-packages.scm
View File

@ -72,6 +72,7 @@
util ; unspecific
channel-i/o ; steal-channel-port
fluids-internal ; get-dynamic-env, set-dynamic-env!
thread-cells-internal ; empty-cell-values
root-scheduler ; call-when-deadlocked!
conditions) ; define-condition-type
(files (env command-level)))

2
scheme/packages.scm
View File

@ -272,6 +272,7 @@
scheme-level-1
scheme-level-2
templates
thread-cells
threads
threads-internal
util
@ -301,6 +302,7 @@
records-internal
root-scheduler
session-data
thread-cells-internal
usual-resumer
;; silly
;; structure-refs

13
scheme/rts-packages.scm
View File

@ -53,6 +53,12 @@
(files (rts fluid))
(optimize auto-integrate))
(define-structures ((thread-cells thread-cells-interface)
(thread-cells-internal thread-cells-internal-interface))
(open scheme-level-1 define-record-types primitives fluids-internal)
(files (rts thread-cell))
(optimize auto-integrate))
(define-structure wind wind-interface
(open scheme-level-1 signals define-record-types
fluids fluids-internal
@ -238,6 +244,7 @@
wind
fluids
fluids-internal ;get-dynamic-env
thread-cells-internal ;get-cell-values
escapes ;primitive-cwcc
conditions ;error?
handle ;with-handler
@ -252,7 +259,8 @@
(files (rts thread) (rts sleep)))
(define-structure scheduler scheduler-interface
(open scheme-level-1 threads threads-internal enumerated enum-case
(open scheme-level-1 threads threads-internal thread-cells-internal
enumerated enum-case
debug-messages
signals) ;error
(files (rts scheduler)))
@ -270,6 +278,7 @@
writing ;display
i/o-internal ;output-port-forcer, output-forcer-id
fluids-internal ;get-dynamic-env
thread-cells-internal ;get-cell-values
interrupts ;with-interrupts-inhibited
wind ;call-with-current-continuation
channel-i/o ;waiting-for-i/o?
@ -318,7 +327,7 @@
i/o ;initialize-i/o, etc.
channel-i/o ;{in,out}put-channel->port, initialize-channel-i/o
session-data ;initialize-session-data!
fluids-internal ;initialize-dynamic-state!
thread-cells-internal ;initialize-dynamic-state!
exceptions ;initialize-exceptions!
interrupts ;initialize-interrupts!
sigevents-internal ;initialize-sigevents!

16
scheme/rts/fluid.scm
View File

@ -27,6 +27,14 @@
(dynamic-env thread-dynamic-env)
(dynamic-point thread-dynamic-point))
;; (define *dynamic-env* (make-thread-cell (empty-dynamic-env)))
;;
;; (define (get-dynamic-env)
;; (thread-cell-ref *dynamic-env*))
;;
;; (define (set-dynamic-env! env)
;; (thread-cell-set! *dynamic-env* env))
(define (get-dynamic-env)
(record-ref (current-thread) 1))
@ -42,9 +50,6 @@
(define (set-dynamic-point! point)
(record-set! (current-thread) 2 point))
(define (initialize-dynamic-state!)
(set-current-thread! (make-thread (empty-dynamic-env) #f)))
;----------------
; Dynamic environment
; A dynamic environment is an alist where the cars are fluid records.
@ -87,8 +92,3 @@
(with-dynamic-env env (car args))
(loop (cddr args)
(cons (cons (car args) (cadr args)) env)))))
; Initialize
(initialize-dynamic-state!)

1
scheme/rts/root-scheduler.scm
View File

@ -30,6 +30,7 @@
(safe-dynamic-env (with-handler root-handler get-dynamic-env))
(thread (make-thread thunk
(get-dynamic-env)
(get-cell-values)
'scheduler-initial-thread)))
(increment-counter! thread-count)
(enqueue-thread! runnable thread)

3
scheme/rts/scheduler.scm
View File

@ -100,7 +100,8 @@
(enqueue-thread! runnable
(make-thread (car event-data)
dynamic-env
(cadr event-data))))
(cadr event-data)
(caddr event-data))))
((no-event)
(values))
(else

74
scheme/rts/thread-cell.scm Normal file
View File

@ -0,0 +1,74 @@
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
(define-record-type thread :thread
(make-thread dynamic-env dynamic-point
cell-values own-cell-values?)
(dynamic-env thread-dynamic-env)
(dynamic-point thread-dynamic-point)
(cell-values thread-cell-values set-thread-cell-values!)
(own-cell-values? thread-own-cell-values? set-thread-own-values?!))
(define (empty-cell-values) '())
(define (get-cell-values)
(record-ref (current-thread) 3))
(define (set-cell-values! values)
(record-set! (current-thread) 3 values))
(define (get-own-cell-values?)
(record-ref (current-thread) 4))
(define (set-own-cell-values? own-values?)
(record-set! (current-thread) 4 own-values?))
(define-record-type thread-cell :thread-cell
(make-thread-cell top)
(top thread-cell-top-level-value set-thread-cell-top-level-value!))
(define (thread-cell-ref thread-cell)
(cond
((assq thread-cell (get-cell-values)) => cdr)
(else (thread-cell-top-level-value thread-cell))))
(define (thread-cell-set! thread-cell val)
(cond
;; This might benefit from reordering: if we don't have a binding
;; here, it's safe to set cell-values regardless of the setting of
;; OWN-CELL-VALUES?. On the other hand, this may mean we copy too
;; much when push comes to shove; probably best to store the
;; original CELL-VALUES instead of OWN-CELL-VALUES?.
((not (get-own-cell-values?))
(let loop ((values (get-cell-values))
(rev-new-values '())
(found? #f))
(cond
((null? values)
(set-cell-values! (if found?
(reverse rev-new-values)
(cons (cons thread-cell val)
(reverse rev-new-values))))
(set-own-cell-values? #t))
((eq? thread-cell (caar values))
(loop (cdr values)
(cons (cons (caar values) val)
rev-new-values)
#t))
(else
(loop (cdr values)
(cons (cons (caar values) (cdar values))
rev-new-values)
found?)))))
((assq thread-cell (get-cell-values))
=> (lambda (pair)
(set-cdr! pair val)))
(else
(set-cell-values! (cons (cons thread-cell val)
(get-cell-values))))))
(define (initialize-dynamic-state!)
(set-current-thread! (make-thread (empty-dynamic-env) #f
(empty-cell-values) #t)))
(initialize-dynamic-state!)

24
scheme/rts/thread.scm
View File

@ -39,13 +39,20 @@
; the list is spliced back together and eN's continuation is resumed.
(define-record-type thread :thread
(really-make-thread dynamic-env dynamic-point continuation scheduler
(really-make-thread dynamic-env dynamic-point
cell-values own-cell-values?
continuation scheduler
queue arguments
events current-task uid name)
thread?
(dynamic-env thread-dynamic-env) ;Must be first! (See fluid.scm)
(dynamic-point thread-dynamic-point set-thread-dynamic-point!)
;Must be second! (See fluid.scm)
;Must be third! (See thread-cell.scm)
(cell-values thread-cell-values set-thread-cell-values!)
;Must be fourth! (See thread-cell.scm)
(own-cell-values? thread-own-cell-values? set-thread-own-values?!)
(continuation thread-continuation set-thread-continuation!)
(queue thread-queue set-thread-queue!)
(arguments thread-arguments set-thread-arguments!)
@ -68,9 +75,11 @@
(define *thread-uid* 0)
(define (make-thread thunk dynamic-env name)
(define (make-thread thunk dynamic-env cell-values name)
(let ((thread (really-make-thread dynamic-env
#f ; dynamic-point root
cell-values
#f ; own-cell-values?
(thunk->continuation
(thread-top-level thunk))
(current-thread) ; scheduler
@ -540,20 +549,26 @@
; scheduler.
(define (spawn thunk . id)
(apply spawn-on-scheduler (thread-scheduler (current-thread)) thunk id))
(apply spawn-on-scheduler
(thread-scheduler (current-thread))
thunk
(thread-cell-values (current-thread))
id))
(define (spawn-on-root thunk . id)
(if (root-scheduler)
(apply spawn-on-scheduler
(root-scheduler)
thunk
(thread-cell-values (current-thread))
id)
(thunk)))
(define (spawn-on-scheduler scheduler thunk . id)
(define (spawn-on-scheduler scheduler thunk cell-values . id)
(schedule-event scheduler
(enum event-type spawned)
thunk
cell-values
(if (null? id) #f (car id))))
; Enqueue a RUNNABLE for THREAD's scheduler.
@ -621,6 +636,7 @@
(set! *thread-uid* 0)
(let ((thread (make-thread #f ; thunk
(get-dynamic-env)
(get-cell-values)
'initial-thread)))
(set-thread-scheduler! thread #f)
(set-thread-time! thread #f)