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
148
149
150
151
152
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; This is the main entry point to the compiler. It returns a template
; that will execute the forms (each of which is a node).
;
; This is written in a somewhat odd fashion to make sure that the forms are
; not retained once they have been compiled.
;(define (compile-forms forms name)
; (if (null? forms)
; (segment->template (sequentially
; (instruction (enum op protocol) 0)
; (deliver-value (instruction (enum op unspecific))
; (return-cont #f)))
; name
; #f ;pc-in-segment
; #f) ;debug data
; (really-compile-forms forms
; (instruction (enum op protocol) 0)
; name)))
;
;(define (really-compile-forms forms segment name)
; (if (null? (cdr forms))
; (segment->template (sequentially segment
; (compile-form (car forms)
; (return-cont #f)))
; name
; #f ;pc-in-segment
; #f) ;debug data
; (really-compile-forms (cdr forms)
; (sequentially segment
; (compile-form (car forms)
; an-ignore-values-cont))
; name)))
(define (compile-forms forms name)
(if (null? forms)
(segment->template (sequentially
(instruction (enum op protocol) 0)
(deliver-value (instruction (enum op unspecific))
(return-cont #f)))
name
#f ;pc-in-segment
#f) ;debug data
(compile-forms-loop (reverse forms) name #f)))
(define (compile-forms-loop forms name next)
(if (null? forms)
next
(compile-forms-loop (cdr forms)
name
(compile-form (car forms) name next))))
; Compile a single top-level form, returning a template. NEXT is either #F or
; a template; if it is a template we jump to it after FORM.
(define (compile-form form name next)
(segment->template (sequentially
(instruction (enum op protocol) 0)
(let ((node (force-node form))
(cont (if next
an-ignore-values-cont
(return-cont #f))))
(if (define-node? node)
(compile-definition node cont)
(compile-expression node 0 cont)))
(if next
(instruction-with-literal (enum op call-template)
next
0)
empty-segment))
name
#f ;pc-in-segment
#f)) ;debug data
(define define-node? (node-predicate 'define syntax-type))
; Definitions must be treated differently from assignments: we must
; use SET-CONTENTS! instead of SET-GLOBAL! because the SET-GLOBAL!
; instruction traps if an attempt is made to store into an undefined
; location.
(define (compile-definition node cont)
(let* ((form (node-form node))
(name (cadr form)))
(sequentially (instruction-with-location (enum op literal)
(node-ref name 'binding)
(node-form name)
value-type)
(instruction (enum op push))
(compile-expression (caddr form)
1
(named-cont (node-form name)))
(deliver-value
(instruction (enum op stored-object-set!)
(enum stob location)
location-contents-offset)
cont))))
(define location-contents-offset
(cond ((assq 'location stob-data)
=> (lambda (stuff)
(let loop ((slots (cdddr stuff)) (i 0))
(if (eq? (caar slots) 'contents)
i
(loop (cdr slots) (+ i 1))))))
(else
(error "can't find location data in STOB-DATA"))))
;----------------
; Make a startup procedure from a list of initialization templates. This
; is only used by the static linker. RESUMER should be a template that
; returns a procedure that takes 5 arguments (the number the VM passes to
; the startup procedure).
(define (make-startup-procedure inits resumer)
(let ((nargs 5))
(append-templates inits
nargs
(sequentially
(maybe-push-continuation
(instruction-with-literal (enum op call-template)
resumer
0)
nargs
(fall-through-cont #f #f))
(instruction (enum op call) nargs)))))
; Return a template that accepts NARGS arguments, invokes TEMPLATES in turn,
; and then calls template FINAL on the arguments.
(define (append-templates templates nargs final)
(segment->template
(sequentially
(instruction (enum op protocol) nargs)
(reduce (lambda (template seg)
(sequentially
(maybe-push-continuation
(instruction-with-literal (enum op call-template)
template
0)
nargs
an-ignore-values-cont)
seg))
final
templates))
#f ; no name
#f ; pc-in-segment = #f
#f)) ; no debug data
(define an-ignore-values-cont (ignore-values-cont #f #f))
|
