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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Martin Gasbichler, Mike Sperber
; A frame contains information about a procedure's current stack frame. It
; also has a list of the literals that will go in the procedure's template
; and the debugging data for the template.
;
; template-index - the location of this procedure's template in the frame
; (#f if the template is not needed)
; env-index - the location of this procedure's environment in the frame
; (#f if the procedure does not use its environment)
; closure-index - the location of this procedure's closure in the frame
; (#f if the closure is not needed)
; size - largest size reached by the frame, in descriptors
; literals - list of literals and bindings referenced
; count - length of LITERALS
; debug-data - debug information (see ddata.scm)
(define-record-type frame :frame
(really-make-frame literals count debug-data template-index env-index closure-index size)
frame?
(template-index frame-template-index)
(env-index frame-env-index)
(closure-index frame-closure-index)
(size frame-size set-frame-size!)
(literals frame-literals set-frame-literals!)
(count frame-count set-frame-count!)
(debug-data frame-debug-data))
; SIZE is the number of values on the stack when the procedure is
; entered (typically the number of arguments). ENV? is true if the
; environment was pushed on after the arguments, TEMPLATE? is true if
; the template was pushed as well. CLOSURE? is true if the closure
; was pushed as well.
(define (make-frame parent name size template? env? closure?)
(let* ((ddata (new-debug-data (adjust-procedure-name name)
(if parent
(frame-debug-data parent)
#f))))
(define (allocate-index really?)
(and really?
(let ((index size))
(set! size (+ 1 size))
index)))
(let* ((closure-index (allocate-index closure?))
(env-index (allocate-index env?))
(template-index (allocate-index template?)))
(really-make-frame '()
0
ddata
template-index env-index closure-index
size))))
(define (adjust-procedure-name name)
(cond ((string? name) ; only files have strings for names
(if (keep-file-names?)
name
#f))
((and (keep-procedure-names?)
(name? name))
(name->symbol name))
(else
#f)))
; Convert an index, which is relative to the base of the frame, to an offset
; from the current stack pointer.
(define (index->offset index depth)
(- depth (+ index 1)))
; Offsets for the template and environment.
(define (template-offset frame depth)
(if (frame-template-index frame)
(index->offset (frame-template-index frame)
depth)
#f))
(define (environment-offset frame depth)
(index->offset (frame-env-index frame)
depth))
; Note that FRAME reaches a size of DEPTH.
(define (depth-check! frame depth)
(if (< (frame-size frame)
depth)
(set-frame-size! frame depth)))
; These two procedures look up bindings and literals in the list of values
; to go in the template. They're added if not already present. The returned
; index is that of template, not the frame's list.
(define (binding->index frame binding name assigned?)
(let loop ((i 0) (l (frame-literals frame)))
(cond ((null? l)
(really-literal->index frame
(make-thingie binding name assigned?)
#f))
((and (thingie? (car l))
(eq? binding (thingie-binding (car l)))
(eq? name (thingie-name (car l))))
(if assigned?
(set-thingie-assigned?! (car l) #t))
(really-literal->index frame #f i))
(else
(loop (+ i 1) (cdr l))))))
(define (literal->index frame thing)
(really-literal->index frame thing
(position thing (frame-literals frame))))
(define (really-literal->index frame thing probe)
(let ((count (frame-count frame)))
(if probe
;; +++ Eliminate duplicate entries.
;; Not necessary, just a modest space saver [how much?].
;; Measurably slows down compilation.
;; when 1 thing, lits = (x), count = 1, probe = 0, want 2
(+ (- count probe)
(- template-overhead 1))
(begin
(if (>= count two-byte-limit)
(assertion-violation 'literal->index
"compiler bug: too many literals"
thing))
(set-frame-literals! frame
(cons thing
(frame-literals frame)))
(set-frame-count! frame (+ count 1))
;; when 1st thing, count = 0, want 2
(+ count template-overhead)))))
(define (position elt list)
(let loop ((i 0) (l list))
(cond ((null? l)
#f)
((equal? elt (car l))
i)
(else
(loop (+ i 1) (cdr l))))))
|
