File: interrupt.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (72 lines) | stat: -rw-r--r-- 2,335 bytes parent folder | download
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
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; Interrupts

(define interrupt-handlers
  (make-vector interrupt-count 0))

(do ((i 0 (+ i 1)))
    ((= i interrupt-count))
  (vector-set! interrupt-handlers i
	       (lambda (enabled-int)
		 (signal 'interrupt i enabled-int))))

(define (initialize-interrupts!)
  (set-interrupt-handlers! interrupt-handlers)
  (set! one-second (time time-option/ticks-per-second #f))
  (set-enabled-interrupts! all-interrupts))

(define time-option/ticks-per-second (enum time-option ticks-per-second))
(define one-second #f)

(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 (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))


; Signal an interrupt if an insufficient amount of memory is reclaimed by
; a garbage collection.  The amount defaults to 10% of the heap.

(define (interrupt-before-heap-overflow! . maybe-required-space)
  (let ((space (if (null? maybe-required-space)
		   (quotient (memory-status memory-status-option/heap-size 0)
			     10)
		   (car maybe-required-space))))
    (vector-set! interrupt-handlers
		 interrupt/memory-shortage
		 (lambda (ei)
		   (memory-status
		        memory-status-option/set-minimum-recovered-space!
			space)
		   (signal 'interrupt interrupt/memory-shortage ei)))
    (memory-status memory-status-option/set-minimum-recovered-space!
		   space)))

(define interrupt/memory-shortage (enum interrupt memory-shortage))
(define memory-status-option/set-minimum-recovered-space!
  (enum memory-status-option set-minimum-recovered-space!))
(define memory-status-option/heap-size
  (enum memory-status-option heap-size))