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

Built the event system directly into the RTS. Built sighandlers above 

it. Removed machinery in low-interrupt.
This commit is contained in:
mainzelm 2001-01-09 15:52:52 +00:00
parent 435afc1e2b
commit c1d6d368e5
13 changed files with 140 additions and 348 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
scheme/interfaces.scm
View File

@ -612,6 +612,19 @@
call-before-heap-overflow!
(interrupt :syntax)))
(define-interface events-interface
(export rts-wait-interrupt
rts-maybe-wait-interrupt
most-recent-event
event?
next-event
event-type
schedule-timer-interrupt!))
(define-interface events-internal-interface
(export waiting-for-os-event?
initialize-events!))
(define-interface writing-interface
(export write
display

2
scheme/packages.scm
View File

@ -291,6 +291,8 @@
methods
meta-methods
interrupts
events
events-internal
low-level
more-types
number-i/o

16
scheme/rts-packages.scm
View File

@ -219,6 +219,18 @@
(files (rts interrupt))
(optimize auto-integrate)) ;mostly for threads package...
(define-structures ((events events-interface)
(events-internal events-internal-interface))
(open scheme-level-1 define-record-types
threads threads-internal
interrupts
architecture)
(files (rts events))
(optimize auto-integrate))
(define-structures ((threads threads-interface)
(threads-internal threads-internal-interface))
(open scheme-level-1 enumerated define-record-types queues
@ -260,7 +272,8 @@
fluids-internal ;get-dynamic-env
interrupts ;with-interrupts-inhibited
wind ;call-with-current-continuation
channel-i/o) ;waiting-for-i/o?
channel-i/o ;waiting-for-i/o?
events-internal) ;waiting-for-os-event?
(access primitives) ;unspecific, wait
(files (rts root-scheduler)))
@ -308,6 +321,7 @@
fluids-internal ;initialize-dynamic-state!
exceptions ;initialize-exceptions!
interrupts ;initialize-interrupts!
events-internal ;initialize-events!
records-internal ;initialize-records!
export-the-record-type ;just what it says
threads-internal ;start threads

1
scheme/rts/init.scm
View File

@ -30,6 +30,7 @@
(lambda ()
(with-threads
(lambda ()
(initialize-events!)
(root-scheduler thunk
200 ; thread quantum, in msec
300)))))))))) ; port-flushing quantum

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

@ -97,7 +97,8 @@
(set-enabled-interrupts! all-interrupts)
#t)
((or time-until-wakeup
(waiting-for-i/o?))
(waiting-for-i/o?)
(waiting-for-os-event?))
(do-some-waiting time-until-wakeup)
(set-enabled-interrupts! all-interrupts)
(root-wait))

78
scsh/event.scm
View File

@ -1,78 +1,16 @@
;;; Functional event system.
;;; System by Olin Shivers, implementation by David Fisher
; Copyright (c) 1999-2001 by Martin Gasbichler. See file COPYING.
(define-record event
type
(next (make-placeholder))
((disclose e) (list "event" (event:type e))))
;;; Extend the functions of the RTS
;Not exported!
(define *most-recent-event* (make-event interrupt/cont))
(define event-lock (make-lock))
(define (most-recent-event) *most-recent-event*)
(define (next-event event) (placeholder-value (event:next event)))
(define (event-type event) (event:type event))
;Called when the interrupt actually happened.
(define (register-interrupt type)
(obtain-lock event-lock)
(let ((new-event (make-event type)))
(placeholder-set! (event:next *most-recent-event*) new-event)
(set! *most-recent-event* new-event))
(release-lock event-lock))
;Wait for an event of a certain type.
(define (wait-interrupt type pre-event)
(let ((event (next-event pre-event)))
(if (eq? (event-type event) type)
event
(wait-interrupt type event))))
(rts-wait-interrupt type pre-event eq?))
;Initialize the system.
(define (install-event-handlers!)
(set! *most-recent-event* (make-event interrupt/cont))
(let loop ((count 0))
(if (< count number-of-interrupts)
(begin
;we're not interested in the setter-function here:
(low-interrupt-register
count
(lambda (enabled-interrupts)
(register-interrupt count)))
(loop (+ count 1))))))
;;; extensions by JMG
;;; takes list of interrupt/xxx's
;;; blocks until one of the interrupts in the set occurs
(define (wait-interrupt-set set pre-event)
(let ((event (next-event pre-event)))
(if (memq (event-type event) set)
event
(wait-interrupt-set set event))))
(rts-wait-interrupt set pre-event interrupt-in-set?))
(define (maybe-wait-interrupt type pre-event)
(rts-maybe-wait-interrupt type pre-event eq?))
; would need placeholder-queue exported..
;(define (placeholder-value-set? placeholder)
; (not (placeholder-queue placeholder)))
(define (maybe-wait-interrupt-set set pre-event)
(rts-maybe-wait-interrupt set pre-event interrupt-in-set?))
(define (most-recent-event? event)
(eq? event (most-recent-event)))
(define (nonblockwait-interrupt type event )
(general-nonblockwait-interrupt type event eq?))
(define (nonblockwait-interrupt-set set event )
(general-nonblockwait-interrupt set event memq))
(define (general-nonblockwait-interrupt waiting-for pre-event compare?)
(if (most-recent-event? pre-event)
#f
(let ((event (next-event pre-event)))
(if (compare? (event-type event) waiting-for)
event
(general-nonblockwait-interrupt waiting-for event compare?)))))

129
scsh/low-interrupt.scm
View File

@ -1,8 +1,13 @@
; Copyright (c) 1999-2001 by Martin Gasbichler. See file COPYING.
(define-enumeration low-interrupt
(i/o-completion
post-gc
keyboard
(
;;; just like the VM:
alarm
keyboard
post-gc
i/o-completion
;;;; os-signal is multiplexed:
chld
cont
hup
@ -27,102 +32,8 @@
(define number-of-interrupts
low-interrupt-count)
(define low-interrupt-handlers-vector
(make-vector number-of-interrupts '()))
(define (low-interrupt-handler-ref interrupt)
(if (or (< interrupt 0) (>= interrupt number-of-interrupts))
(error "ill signum in low-interrupt-handler-ref" interrupt)
(vector-ref low-interrupt-handlers-vector interrupt)))
(define (set-low-interrupt-handler! int handler)
(if (or (< int 0) (>= int number-of-interrupts))
(error "ill signum in set-low-interrupt-handler!" int)
(vector-set! low-interrupt-handlers-vector int handler)))
;;; register a handler for interrupt
;;; the handler is called whenever interrupt occurs among all others,
;;; which registered for this interrupt
;;; return value is a function which allows to change the handler
(define (low-interrupt-register interrupt handler)
(let* ((old (low-interrupt-handler-ref interrupt))
(the-lock (make-lock))
(new-cell (cons handler the-lock)))
(set-low-interrupt-handler! interrupt (cons new-cell old))
(lambda (new-handler)
(obtain-lock the-lock)
(set-car! new-cell new-handler)
(release-lock the-lock))))
(define (init-low-interrupt)
(spawn
(lambda ()
(let ((I (current-thread)))
(set-interrupt-handler!
(enum interrupt os-signal)
(lambda (type arg enabled-interrupts)
(schedule-event I
(enum event-type interrupt)
(enum interrupt os-signal)
type
enabled-interrupts)))
(set-interrupt-handler!
(enum interrupt keyboard)
(lambda (enabled-interrupts)
(schedule-event I
(enum event-type interrupt)
(enum interrupt keyboard)
enabled-interrupts)))
(let loop ()
(wait)
(call-with-values
get-next-event!
(lambda (event . data)
(if (eq? event (enum event-type interrupt))
(let ((i-nr (car data)))
(if (eq? i-nr (enum interrupt os-signal))
(call-handlers (cadr data) (caddr data))
(if (eq? i-nr (enum interrupt keyboard))
(call-handlers (enum low-interrupt keyboard)
(cadr data))))))))
(loop))))
'low-interrupt-deliver-thread)
(call-after-gc!
(lambda ()
(let ((enabled-interrupts "JMG: enabled interrupts not yet impl"))
(call-handlers (enum low-interrupt post-gc) enabled-interrupts))))
#t)
;;; the vm-interrupts should be called with interrupts disabled, but
;;; the self generated are not and a lock provides the same functionality
(define interrupt-deliver-lock (make-lock))
(define (call-handlers low-interrupt enabled-interrupts)
(for-each (lambda (handler-lock-pair)
((car handler-lock-pair) enabled-interrupts))
(low-interrupt-handler-ref low-interrupt)))
;;; the vm uses the timer for the scheduler
(define (itimer sec)
(spawn (lambda ()
(sleep (* sec 1000))
(let ((enabled-interrupts "JMG: enabled interrupts not yet impl"))
(call-handlers (enum low-interrupt alarm) enabled-interrupts)))))
(define interrupt/alarm (enum low-interrupt alarm))
(define interrupt/keyboard (enum low-interrupt keyboard))
;(define interrupt/memory-shortage (enum low-interrupt memory-shortage))
(define interrupt/post-gc (enum low-interrupt post-gc))
(define interrupt/i/o-completion (enum low-interrupt i/o-completion))
(define interrupt/chld (enum low-interrupt chld))
@ -146,3 +57,27 @@
(define interrupt/int interrupt/keyboard)
(define interrupt/alrm interrupt/alarm)
(define (interrupt-set . interrupts)
(let lp ((ints interrupts) (ans 0))
(if (pair? ints)
(lp (cdr ints) (bitwise-ior ans (arithmetic-shift 1 (car ints) )))
ans)))
(define (interrupt-in-set? int set)
(not (zero? (bitwise-and (arithmetic-shift 1 int) set))))
(define (insert-interrupt int set)
(bitwise-ior (arithmetic-shift 1 int) set))
(define (remove-interrupt int set)
(if (interrupt-in-set? int set)
(bitwise-xor (arithmetic-shift 1 int) set)
set))
(define full-interrupt-set
(let lp ((ans 0) (count (- number-of-interrupts 1)))
(if (< count 0)
ans
(lp (insert-interrupt count ans) (- count 1)))))

4
scsh/procobj.scm
View File

@ -112,8 +112,8 @@
;;; I'm really tired of opening everything (i.e. events) in scsh-level-0
;;; this is here until someone (Olin !!!) cleans up the scsh modules
(define wait-interrupt (structure-ref events wait-interrupt))
(define most-recent-event (structure-ref events most-recent-event))
(define wait-interrupt (structure-ref scsh-events wait-interrupt))
(define most-recent-event (structure-ref scsh-events most-recent-event))
(define *autoreap-policy* #f) ; Not exported from this module.

27
scsh/scsh-interfaces.scm
View File

@ -1110,28 +1110,22 @@
interrupt/xcpu
interrupt/xfsz))
(define-interface event-interface
(define-interface scsh-events-interface
(export most-recent-event
most-recent-event?
event?
next-event
event-type
wait-interrupt
wait-interrupt-set
nonblockwait-interrupt
nonblockwait-interrupt-set
install-event-handlers!))
maybe-wait-interrupt
maybe-wait-interrupt-set))
(define-interface low-interrupt-interface
(export low-interrupt-register
init-low-interrupt
number-of-interrupts
itimer
interrupt/alrm interrupt/alarm
(export number-of-interrupts
interrupt/alrm interrupt/alarm
interrupt/int interrupt/keyboard
; interrupt/memory-shortage
interrupt/post-gc
interrupt/i/o-completion
interrupt/chld
@ -1151,7 +1145,12 @@
interrupt/vtalrm
interrupt/winch
interrupt/xcpu
interrupt/xfsz))
interrupt/xfsz
interrupt-set
interrupt-in-set?
insert-interrupt
remove-interrupt
full-interrupt-set))
(define-interface locks-interface
(export obtain-lock

28
scsh/scsh-package.scm
View File

@ -142,7 +142,7 @@
; (scsh-regexp-package scsh-regexp-interface)
)
(for-syntax (open scsh-syntax-helpers scheme))
(access events)
(access events scsh-events)
(open enumerated
defenum-package
external-calls ;JMG new FFI
@ -281,7 +281,7 @@
scsh-utilities
interrupts
low-interrupt
events
scsh-events
primitives
scheme)
(files startup))
@ -297,7 +297,7 @@
evaluation
extended-ports
interfaces
events
scsh-events
low-interrupt
fluids-internal ; JMG: get-dynamic-env
handle ; JMG: with-handler
@ -402,14 +402,12 @@
scheme)
(files here))
(define-structure events event-interface
(define-structure scsh-events scsh-events-interface
(open scsh-level-0
defrec-package
locks
placeholders
architecture
scheme
low-interrupt)
structure-refs
low-interrupt
events)
(files event))
(define-structure simple-syntax (export define-simple-syntax)
@ -421,14 +419,10 @@
(define-structure low-interrupt low-interrupt-interface
(open enumerated
locks
error-package
i/o ;current-error-port
interrupts ; signal handler code
scheme
threads-internal
threads)
(open scheme
enumerated
bigbit
bitwise)
(files low-interrupt))
;(define-structure test-package (export test-proc)

180
scsh/sighandlers.scm
View File

@ -49,17 +49,11 @@
(error "Unix signal has no Scheme 48 interrupt." sig))))
(define (interrupt-set . interrupts)
(let lp ((ints interrupts) (ans 0))
(if (pair? ints)
(lp (cdr ints) (bitwise-ior ans (arithmetic-shift 1 (car ints) )))
ans)))
(define (interrupt-enabled? int mask)
(not (zero? (bitwise-and (arithmetic-shift 1 int) mask))))
(interrupt-in-set? int mask))
(define (interrupt-enable int mask)
(bitwise-ior (arithmetic-shift 1 int) mask))
(insert-interrupt int mask))
(define *enabled-interrupts*
(let lp ((i 0) (mask 0))
@ -69,6 +63,16 @@
(define (enabled-interrupts) *enabled-interrupts*)
(define *pending-interrupts* 0)
(define (interrupt-pending? int)
(interrupt-in-set? int *pending-interrupts*))
(define (make-interrupt-pending int)
(insert-interrupt int *pending-interrupts*))
(define (remove-pending-interrupt int)
(remove-interrupt int *pending-interrupts*))
;;; I'm trying to be consistent about the ! suffix -- I don't use it
;;; when frobbing process state. This is not a great rule; perhaps I
@ -80,81 +84,10 @@
((= int number-of-interrupts) new-enabled-interrupts)
(let ((old-state (interrupt-enabled? int *enabled-interrupts*))
(new-state (interrupt-enabled? int new-enabled-interrupts)))
(cond ((and old-state (not new-state))
(vector-set! blockade-vector int (block-interrupt int)))
((and (not old-state) new-state)
(let ((blockade (vector-ref blockade-vector int)))
(if (not blockade)
(error "there was no blockade" int))
(unblock-interrupt blockade)
(vector-set! blockade-vector int #f)))
(else 'unchanged))))
(if (and (not old-state) new-state (interrupt-pending? int))
(call-interrupt-handler int))))
(set! *enabled-interrupts* new-enabled-interrupts))
;;; Enableing/Disableing = Unblocking/Blocking
;;;
;;; issues:
;;; + prevent delivery of the interrupt => install fake handler in
;;; low-interrupt
;;; + support setting of handler during blocking => install fake
;;; set-proc in interrupt-handler-vector
;;; + record if an interrupt occures while interupt blocked => pending?
;;; + restore everything after interrupt unublocked => reinstall handler
;;; in low-interrupt, set-proc in interrupt-handler-vector
;;; + if pending? interrupt: call handler
;(define-record-type blockade :blockade
; (really-make-blockade interrupt-vector-cell pending? low-int-set!)
; blockade?
; (interrupt-vector-cell blockade:interrupt-vector-cell)
; (pending? blockade:pending? set-blockade:pending?)
; (low-int-set! blockade:low-int-set!))
(define-record blockade
interrupt-vector-cell
low-int-set! ; proc to set interrupt in low-interrupt
(pending? #f))
(define blockade-vector (make-vector number-of-interrupts #f))
;;; do nothing in low-interrupt, the new handler will be recorded in the
;;; interrupt-handler-vector however
(define (fake-set-interrupt blockade)
(lambda (new-handler)
#f))
;;; to be installed in low-interrupt
(define (fake-handler blockade)
(lambda a
(if (not (blockade:pending? blockade))
(set-blockade:pending? blockade a))))
;;; generate blockade and install fake handler and set-proc
(define (block-interrupt int)
(let* ((handler-setter-cell (vector-ref *interrupt-handlers-vector* int))
(low-int-set! (cdr handler-setter-cell))
(blockade (make-blockade handler-setter-cell
low-int-set!)))
; fade out the low-interupt-set
(set-cdr! handler-setter-cell (fake-set-interrupt blockade))
; set the fake handler in low-interupt:
((blockade:low-int-set! blockade) (fake-handler blockade))
blockade))
(define (unblock-interrupt blockade)
(let ((handler (car (blockade:interrupt-vector-cell blockade))))
; install the handler that resides in the vector
(let ((low-int-set! (blockade:low-int-set! blockade)))
(low-int-set! handler)
; reinstall the low-interrupt-setter
(set-cdr! (blockade:interrupt-vector-cell blockade)
low-int-set!)
(if (blockade:pending? blockade)
(apply handler (blockade:pending? blockade))))))
(define-simple-syntax (with-enabled-interrupts interrupt-set body ...)
(begin
(with-enabled-interrupts* interrupt-set (lambda () body ...))))
@ -167,12 +100,8 @@
return)))
; Fakes vm vector
;;; car is the actual handler, cdr is a proc to set handler in
;;; low-interrupt system
(define *interrupt-handlers-vector*
(make-vector number-of-interrupts (cons #f #f)))
(make-vector number-of-interrupts #t))
(define (interrupt-handlers-vector)
*interrupt-handlers-vector*)
@ -180,30 +109,15 @@
(define (interrupt-handler-ref int)
(if (or (< int 0) (>= int number-of-interrupts))
(error "ill signum in interrupt-handler-ref" int)
(car (vector-ref *interrupt-handlers-vector* int))))
(vector-ref *interrupt-handlers-vector* int)))
;;; the handler is not interested in the enabled interupts of the vm
;;; but in those managed here
(define (make-handler handler)
(lambda (enabled-low)
(handler (enabled-interrupts))))
(define (set-interrupt-handler! int handler)
(if (or (< int 0) (>= int number-of-interrupts))
(error "ill signum in set-interrupt-handler!" int)
(let ((handler-setter (vector-ref *interrupt-handlers-vector* int))
(handler-enabled-here (make-handler handler)))
(if (not (cdr handler-setter)) ; not yet registered?
(let ((setter (low-interrupt-register
int handler-enabled-here)))
(vector-set! *interrupt-handlers-vector*
int
(cons handler setter)))
(begin
((cdr handler-setter) handler-enabled-here) ; set it with setter
(set-car! (vector-ref *interrupt-handlers-vector* int)
handler))))))
(define (call-interrupt-handler int)
(let ((handler (interrupt-handler-ref int)))
(case handler
((#t) ((vector-ref default-int-handler-vec int) (enabled-interrupts)))
((#f) (if #f #f))
(else (handler (enabled-interrupts))))))
;;; Get/Set signal handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -242,38 +156,18 @@
;;; register. If the procedure returns normally, the ENABLED-INTERRUPTS
;;; register will be restored to its previous value.
;;; This handler does nothing -- used when the handler is #f.
(define (noop-sig-handler enabled-interrupts) #f)
(define (set-interrupt-handler int handler)
(let ((ohandler (interrupt-handler int)))
(set-interrupt-handler!
int
(case handler
((#t) (vector-ref default-int-handler-vec int))
((#f) noop-sig-handler)
(else handler)))
ohandler))
; (cond ((and (not handler) ohandler ; Toggling from something
; (int->signal int)) => ; to ignored.
; (lambda (sig)
; (%set-unix-signal-handler sig 0)))
; ((and handler (not ohandler) ; Toggling from ignored
; (int->signal int)) => ; to something.
; (lambda (sig)
; (%set-unix-signal-handler sig 2))))
; ohandler))
(if (or (< int 0) (>= int number-of-interrupts))
(error "ill signum in set-interrupt-handler!" int)
(let ((old-handler (vector-ref *interrupt-handlers-vector* int)))
(vector-set! *interrupt-handlers-vector* int handler)
old-handler)))
(define (interrupt-handler int)
(let ((handler (interrupt-handler-ref int)))
(cond ((eq? handler (vector-ref default-int-handler-vec int)) #t)
((eq? handler noop-sig-handler) #f)
(else handler))))
(interrupt-handler-ref int))
(define (%install-scsh-handlers interactive?)
(display "install-scsh-handlers???\n")
(do ((int 0 (+ int 1)))
((= int number-of-interrupts))
(set-interrupt-handler
@ -283,11 +177,11 @@
((< sig 0))
(let ((i (%signal->interrupt sig)))
(if (not (or (= i -1)
; (= sig signal/int) ; Leave ^c and
(= sig signal/int) ; Leave ^c and
(= sig signal/alrm))) ; alarm handlers alone.
(set-interrupt-handler
i
(vector-ref default-int-handler-vec i)))))
#t))))
(let ((scheduler-initial-thread (current-thread)))
(if (not (eq? (thread-name scheduler-initial-thread)
'scheduler-initial-thread))
@ -304,8 +198,16 @@
(enum
(structure-ref threads-internal event-type)
interrupt)
(enum interrupt keyboard)))))))
(enum interrupt keyboard))))))
(spawn deliver-interrupts 'deliver-interrupts))
(define (deliver-interrupts)
(let lp ((last ((structure-ref scsh-events most-recent-event))))
(let ((event ((structure-ref scsh-events wait-interrupt-set)
full-interrupt-set last)))
(call-interrupt-handler ((structure-ref scsh-events event-type) event))
(lp event))))
;;; I am ashamed to say the 33 below is completely bogus.
;;; What we want is a value that is 1 + max interrupt value.

2
scsh/startup.scm
View File

@ -44,8 +44,6 @@
(define (dump-scsh-program start filename)
(really-dump-scsh-program (lambda (args)
(init-low-interrupt)
(install-event-handlers!)
(install-env)
(%install-scsh-handlers #f)
(install-autoreaping)

5
scsh/top.scm
View File

@ -219,8 +219,6 @@
(get-reflective-tower (user-environment)) ; ???
name))
(define (forever-sleeping-thread) (sleep 10000) (forever-sleeping-thread))
(define (parse-switches-and-execute all-args context)
(receive (switches term-switch term-val top-entry args)
(parse-scsh-args (cdr all-args))
@ -237,8 +235,6 @@
(user-environment)
(lambda ()
(begin
(init-low-interrupt)
(install-event-handlers!)
(%install-scsh-handlers (not term-switch))
(install-autoreaping)
(install-env)
@ -267,7 +263,6 @@
args
context
(lambda ()
(spawn forever-sleeping-thread)
(display "welcome to scsh-0.6 alpha "
(current-output-port))
(newline (current-output-port))