1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, David Frese
; Interrupts
; Create and install a vector of interrupt handlers. We want this to happen
; as early as possible. All but the post-gc and keyboard interrupts raise a
; VM exception by default. We exit when a keyboard interrupt occurs. The default
; post-gc handlers are defined below.
(define (initialize-interrupts! spawn-on-root thunk)
(primitive-cwcc
(lambda (exit)
(let ((handlers (make-vector interrupt-count 0)))
(do ((i 0 (+ i 1)))
((= i interrupt-count))
(vector-set! handlers
i
(lambda stuff
(signal-condition (condition
(make-interrupt-condition (car stuff))
(make-irritants-condition (cdr stuff)))))))
(vector-set! handlers
(enum interrupt post-major-gc)
(post-gc-handler #t spawn-on-root))
(vector-set! handlers
(enum interrupt post-minor-gc)
(post-gc-handler #f spawn-on-root))
(vector-set! handlers
(enum interrupt keyboard)
(lambda args
(with-continuation exit (lambda () -1))))
(set-interrupt-handlers! handlers)
(session-data-set! interrupt-handlers handlers))
(set-enabled-interrupts! all-interrupts)
(thunk))))
(define interrupt-handlers (make-session-data-slot! 0))
; Set an interrupt handler.
(define (set-interrupt-handler! interrupt handler)
(vector-set! (session-data-ref interrupt-handlers)
interrupt
handler))
(define (get-interrupt-handler interrupt)
(vector-ref (session-data-ref interrupt-handlers)
interrupt))
(define no-interrupts 0)
(define all-interrupts
(- (arithmetic-shift 1 interrupt-count) 1))
(define (with-interrupts-inhibited thunk)
(with-interrupts no-interrupts thunk))
(define (with-interrupts-allowed thunk)
(with-interrupts all-interrupts thunk))
(define (disable-interrupts!)
(set-enabled-interrupts! no-interrupts))
(define (enable-interrupts!)
(set-enabled-interrupts! all-interrupts))
(define (with-interrupts interrupts thunk)
;; I might consider using dynamic-wind here, but (a) I'm worried
;; about the speed of thread switching (which uses this) and (b)
;; it's a pretty bad idea to throw in or out of one of these anyhow.
(let ((ei (set-enabled-interrupts! interrupts)))
(call-with-values thunk
(lambda results
(set-enabled-interrupts! ei)
(apply values results)))))
(define (enabled-interrupts) ;For debugging
(let ((e (set-enabled-interrupts! 0)))
(set-enabled-interrupts! e)
e))
;----------------
; Post-GC interrupts
(define *post-gc-procedures* '())
(define (call-after-gc! thunk)
(if (not (memq thunk *post-gc-procedures*))
(set! *post-gc-procedures* (cons thunk *post-gc-procedures*))))
(define (post-gc-handler major? spawn-on-root)
(lambda (finalizer-list enabled-interrupts in-trouble?)
(if in-trouble?
(spawn-on-root
(lambda ()
((session-data-ref space-shortage-handler)))))
(spawn-on-root
(lambda ()
(for-each (lambda (p)
((cdr p) (car p)))
finalizer-list)
(if major?
(for-each (lambda (thunk)
(thunk))
*post-gc-procedures*)))
'post-gc-handler)
(set-enabled-interrupts! enabled-interrupts)))
(define space-shortage-handler
(make-session-data-slot! (lambda (required space) #f)))
(define (call-before-heap-overflow! handler . maybe-required-space-percentage)
(session-data-set! space-shortage-handler handler))
|
