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
153
154
155
156
157
158
159
160
161
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Martin Gasbichler, Mike Sperber
; 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 package-key)
(with-package-key package-key
(lambda ()
(if (null? forms)
(segment->template (sequentially
(lambda-protocol 0 #t #f #f)
(deliver-value (instruction (enum op unspecific))
(return-cont #f)))
(make-frame #f name 0 #f #f #f))
(compile-forms-loop (reverse forms)
name
#f))))) ;next template
(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.
; Stack has zero args, no env, template.
(define (compile-form form name next)
(let ((frame (make-frame #f name 0 #t #f #f)))
(segment->template
(sequentially
(lambda-protocol 0 #t #f #f) ; template, no env, no closure
(let ((node (flatten-form (force-node form))))
(cond ((define-node? node)
(sequentially
(compile-definition node frame an-ignore-values-cont)
(if next
(call-template-inst next #f 0 1 frame)
(instruction (enum op values) 0 0))))
(next
(sequentially
(compile-expression node 1 frame an-ignore-values-cont)
(call-template-inst next #f 0 1 frame)))
(else
(compile-expression node 1 frame (return-cont #f))))))
frame)))
(define (call-template-inst template label nargs depth frame)
(let ((offset (template-offset frame depth))
(index (literal->index frame template)))
(using-optional-label (enum op call-template)
label
(high-byte offset)
(low-byte offset)
(high-byte index)
(low-byte index)
nargs)))
(define (template-call template depth frame cont)
(receive (before depth label after)
(push-continuation depth frame cont #f)
(sequentially before
(call-template-inst template label 0 depth frame)
after)))
; Definitions must be treated differently from assignments: we must
; use STORED-OBJECT-SET! instead of SET-GLOBAL! because the SET-GLOBAL!
; instruction traps if an attempt is made to store into an undefined
; location.
;
; Called with a stack depth of one (the template).
(define (compile-definition node frame cont)
(let* ((form (node-form node))
(name (cadr form)))
(sequentially (stack-indirect-instruction
(template-offset frame 1)
(binding->index frame
(node-ref name 'binding)
(node-form name)
#f))
(begin (depth-check! frame 2)
(instruction (enum op push)))
(compile-expression (caddr form)
2 ; stack depth
frame
(named-cont (node-form name)))
(deliver-value
(instruction (enum op stored-object-set!)
(enum stob location)
location-contents-offset
0) ; do not log in current proposal
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
(assertion-violation 'location-contents-offset
"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 8 arguments (the number the VM passes to
; the startup procedure).
; The length of the argument list needs to be in sync with
; MAKE-USUAL-RESUMER in rts/init.scm, and S48-CALL-STARTUP-PROCEDURE
; in vm/interp/resume.scm.
(define (make-startup-procedure inits resumer)
(let* ((nargs 8)
(frame (make-frame #f ; no parent
#f ; no name
nargs ; args on stack
#t ; keep template
#f ; drop environment
#f))) ; drop closure
(append-templates inits
nargs
frame
(sequentially
(template-call resumer
(+ nargs 1) ; args + template
frame
(fall-through-cont #f #f))
(instruction (enum op pop-n) 0 1) ; remove template
(instruction (enum op tail-call) nargs 0 0)))))
; Return a template that accepts NARGS arguments, invokes TEMPLATES in turn,
; and then calls template FINAL on the arguments.
(define (append-templates templates nargs frame final)
(segment->template
(sequentially
(lambda-protocol nargs #t #f #f) ; push template
(reduce (lambda (template seg)
(sequentially
(template-call template
(+ nargs 1) ; arguments + template
frame
an-ignore-values-cont)
seg))
final
templates))
frame))
(define an-ignore-values-cont (ignore-values-cont #f #f))
|
