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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
; Entry point
(define (prescheme-compiler package-id spec-files init-name c-file . commands)
(reset-node-id)
(initialize-lambdas)
(reset-record-data!)
(reset-type-vars!)
(receive (copy no-copy shadow integrate header)
(parse-prescheme-commands commands)
(let ((forms (prescheme-front-end (if (list? package-id)
package-id
(list package-id))
spec-files copy no-copy shadow)))
(for-each simplify-form forms)
(let ((forms (remove-unreferenced-forms forms)))
(for-each integrate-stob-form forms)
; prevent further automatic integration
(for-each (lambda (form)
(remove-variable-known-value! (form-var form)))
forms)
(integrate-by-command integrate forms)
(for-each resimplify-form forms)
(let* ((forms (remove-unreferenced-forms forms))
(forms (integrate-single-uses forms))
(forms (remove-unreferenced-forms forms)))
(for-each resimplify-form forms)
(for-each determine-form-protocol forms)
(let ((forms (form-tail-calls->jumps forms)))
(for-each maybe-add-self-label forms)
(let ((forms (hoist-nested-procedures forms)))
(for-each remove-polymorphism forms)
; (if cps-file (write-cps-file cps-file forms))
(if c-file (write-c-file init-name c-file header forms)))))))))
;(define (expand-and-eval-program package-id spec-files output-file . commands)
; (reset-node-id)
; (reset-record-data!)
; (receive (copy no-copy shadow integrate header)
; (parse-prescheme-commands commands)
; (let ((forms (prescheme-front-end package-id spec-files copy no-copy shadow)))
; (call-with-output-file output-file
; (lambda (out)
; (display-forms-as-scheme forms out))))))
;(define (simplify-and-print-program package-id spec-files output-file c-file . commands)
; (reset-node-id)
; (reset-record-data!)
; (receive (copy no-copy shadow integrate header)
; (parse-prescheme-commands commands)
; (let ((forms (prescheme-front-end package-id spec-files copy no-copy shadow)))
; (for-each simplify-form forms)
; (let ((forms (remove-unreferenced-forms forms)))
; (call-with-output-file output-file
; (lambda (out)
; (display-cps-forms-as-scheme forms out)))))))
(define command-names '(copy no-copy shadow integrate header))
(define (parse-prescheme-commands commands)
(let ((res (map list command-names)))
(for-each (lambda (command)
(cond ((assq (car command) res)
=> (lambda (l)
(set-cdr! l (append (reverse (cdr command))
(cdr l)))))
(else
(error "unknown directive ~S" command))))
commands)
(apply values (map (lambda (l) (reverse (cdr l))) res))))
;--------------------------------------------------
(define (simplify-form form)
(format #t " ~A " (form-name form))
(let ((status (expand-and-simplify-form form)))
(if status
(format #t "(~A): " status)
(format #t ": "))
(display-type (variable-type (form-var form))
(current-output-port))
(newline (current-output-port))))
;--------------------------------------------------
(define (integrate-single-uses forms)
(format #t "In-lining single-use procedures~%")
(let loop ((forms forms) (done '()) (hit? #f))
(cond ((null? forms)
(if hit?
(loop (reverse done) '() #f)
(reverse done)))
((single-called-use? (car forms))
(let ((form (car forms)))
; (format #t " ~S~%" (variable-name (form-var form)))
(integrate-single-use form
(car (variable-refs (form-var form)))
#f)
(set-form-value! form #f)
(make-form-unused! form)
(loop (cdr forms) done #t)))
(else
(loop (cdr forms) (cons (car forms) done) hit?)))))
(define (single-called-use? form)
(let ((var (form-var form)))
(and (not (form-exported? form))
(eq? (form-type form) 'lambda)
(not (null? (variable-refs var)))
(null? (cdr (variable-refs var)))
(called-node? (car (variable-refs var))))))
(define (integrate-single-use form ref copy?)
(let* ((in-node (node-base ref))
(in-form (node-form in-node))
(type (variable-type (form-var form))))
(use-this-form! in-form)
(let ((node (cond (copy?
(copy-node-tree (form-node form)))
(else
(also-use-this-form! form)
(form-node form)))))
(if (type-scheme? type)
(if (not (called-node? ref))
(error "integrating polymorphic value into non-call position")
(instantiate-type&value type node ref)))
(determine-lambda-protocol node (list ref))
(replace ref node)
(simplify-all in-node (form-name form))
(suspend-form-use! in-form))))
; Commands are (<proc> <caller>)
(define (integrate-by-command commands forms)
(for-each (lambda (command)
(receive (proc refs)
(process-integrate-command command forms)
(if proc
(for-each (lambda (r)
(integrate-single-use proc r #t))
refs))))
commands))
; Horrendous error checking and notification.
(define (process-integrate-command command forms)
(let* ((proc (any (lambda (f)
(eq? (form-name f) (car command)))
forms))
(var (if proc (form-var proc) #f))
(node (if proc (form-value proc) #f))
(caller (any (lambda (f)
(eq? (form-name f) (cadr command)))
forms))
(refs (if (and var caller)
(filter (lambda (ref)
(eq? caller (node-form ref)))
(variable-refs var))
#f)))
(cond ((or (not proc) (not var) (not caller))
(cond ((or (not proc) (not var))
(format #t "Bad command: no value for ~S~%"
(car command)))
((or (not node)
(not (lambda-node? node)))
(format #t "Bad command: ~S is not a procedure~%"
(car command))))
(if (not caller)
(format #t "Bad command: no definition for ~S~%"
(cadr command)))
(values #f #f))
((or (null? refs) (not node) (not (lambda-node? node)))
(if (null? refs)
(format #t "Bad command: ~S is not referenced by ~S~%"
(car command) (cadr command)))
(if (or (not node)
(not (lambda-node? node)))
(format #t "Bad command: ~S is not a procedure~%"
(car command)))
(values #f #f))
(else
(values proc refs)))))
;--------------------------------------------------
(define (determine-form-protocol form)
(let ((var (form-var form)))
(cond ((and (not (form-exported? form))
(eq? 'lambda (form-type form))
(every? called-node? (variable-refs var)))
(determine-lambda-protocol (form-node form) (variable-refs var))
(note-known-global-lambda! var (form-node form))))))
;--------------------------------------------------
(define (form-tail-calls->jumps forms)
(receive (hits useless)
(find-jump-procs (filter-map (lambda (form)
(if (eq? 'lambda (form-type form))
(form-node form)
#f))
forms)
find-form-proc-calls)
(for-each (lambda (p)
(let* ((procs (cdr p))
(proc-forms (map node-form procs))
(owner (node-flag (node-base (car p))))
(vars (map form-var proc-forms)))
(use-this-form! owner)
(for-each also-use-this-form! proc-forms)
(procs->jumps (cdr p) vars (car p))
(simplify-node (form-value owner)) ; worth it?
(suspend-form-use! owner)
(for-each (lambda (f)
(set-form-value! f #f)
(make-form-unused! f))
proc-forms)))
hits)
(for-each (lambda (p)
(make-form-unused! (node-form p)))
useless)
(filter (lambda (f)
(not (eq? (form-type f) 'unused)))
forms)))
(define (find-form-proc-calls l)
(let ((refs (variable-refs (form-var (node-form l)))))
(cond ((and refs (every? called-node? refs))
refs)
((calls-known? l)
(bug "cannot find calls for known lambda ~S" l))
(else #f))))
;--------------------------------------------------
; Determine an actual type for a polymorphic procedure.
(define (remove-polymorphism form)
(if (and (null? (variable-refs (form-var form)))
(eq? 'lambda (form-type form)))
(for-each (lambda (var)
(if (and (null? (variable-refs var))
(uvar? (maybe-follow-uvar (variable-type var))))
(unused-variable-warning var form)))
(cdr (lambda-variables (form-node form)))))
(if (type-scheme? (variable-type (form-var form)))
(make-monomorphic! (form-var form))))
(define (unused-variable-warning var form)
(format #t "Warning: argument `~S' of `~S' is not used, and `~S' is not called;~%"
(variable-name var) (form-name form) (form-name form))
(format #t " assuming the type of argument `~S' of procedure `~S' is `long'.~%"
(variable-name var) (form-name form))
(set-variable-type! var type/integer))
;--------------------------------------------------
; Various methods for getting values from thunks. These are no longer used
; here.
(define (thunk-value thunk)
(let ((refs (variable-refs (car (lambda-variables thunk)))))
(if (= 1 (length refs))
(call-arg (node-parent (car refs)) 2)
#f)))
(define (simple-thunk? thunk value)
(eq? (node-parent (node-parent value)) thunk))
;----------------------------------------------------------------
; Turning internal tail-recursive calls to jumps.
; f = (proc (c . vars)
; ... ([unknown-]tail-call c f . args) ...)
; =>
; f = (proc (c . vars)
; (letrec ((f' (jump . vars) ... (jump f' . args) ...))
; (jump f' . vars)))
(define (maybe-add-self-label form)
(if (eq? 'lambda (form-type form))
(let* ((node (form-node form))
(self-calls (filter (lambda (ref)
(and (eq? (node-index ref) 1)
(calls-this-primop? (node-parent ref)
(if (calls-known? node)
'tail-call
'unknown-tail-call))
(eq? node (node-base ref))))
(variable-refs (form-var form)))))
(if (not (null? self-calls))
(begin
(use-this-form! form)
(replace-self-calls-with-jumps node self-calls)
(suspend-form-use! form))))))
(define (replace-self-calls-with-jumps proc refs)
(let* ((outside-var (reference-variable (car refs)))
(var (make-variable (variable-name outside-var)
(variable-type outside-var)))
(old-vars (cdr (lambda-variables proc)))
(new-vars (map copy-variable old-vars))
(args (map make-reference-node new-vars))
(body (lambda-body proc))
(jump-proc (make-lambda-node (lambda-name proc) 'jump old-vars)))
(for-each (lambda (var)
(set-variable-binder! var proc))
new-vars)
(set-cdr! (lambda-variables proc) new-vars)
(for-each (lambda (ref)
(let ((call (node-parent ref)))
(if (not (calls-known? proc))
(remove-call-arg call 2)) ; remove TAIL? argument
(remove-call-arg call 0) ; remove continuation argument
(replace (call-arg call 0) (make-reference-node var))
(set-call-primop! call (get-primop (enum primop jump)))))
refs)
(let-nodes ((call (jump 0 (* var) . args)))
(move-body body (lambda (body)
(attach-body jump-proc body)
call))
(put-in-letrec (list var) (list jump-proc) call))))
|
