| blob | 5a92c8da871f56032ed1662eb00a8fa90ec70d8d |
1 ;;;; File: "comp.scm", Time-stamp: <2009-08-21 23:41:38 feeley>
3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
4 ;;;; All Rights Reserved.
6 (define gen-instruction
7 (lambda (instr nb-pop nb-push ctx)
8 (let* ((env
9 (context-env ctx))
10 (stk
11 (stack-extend #f
12 nb-push
13 (stack-discard nb-pop
14 (env-local env)))))
15 (context-add-instr (context-change-env ctx (env-change-local env stk))
16 instr))))
18 (define gen-entry
19 (lambda (nparams rest? ctx)
20 (gen-instruction (list 'entry nparams rest?) 0 0 ctx)))
22 (define gen-push-constant
23 (lambda (val ctx)
24 (gen-instruction (list 'push-constant val) 0 1 ctx)))
26 (define gen-push-unspecified
27 (lambda (ctx)
28 (gen-push-constant #f ctx)))
30 (define gen-push-local-var
31 (lambda (var ctx)
32 ; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx))))
33 (let ((i (find-local-var var (context-env ctx))))
34 (if (>= i 0)
35 (gen-push-stack i ctx)
36 (gen-push-stack
37 (+ (- -1 i)
38 (length (stack-slots (env-local (context-env ctx))))) ctx)))))
40 (define gen-push-stack
41 (lambda (pos ctx)
42 (gen-instruction (list 'push-stack pos) 0 1 ctx)))
44 (define gen-push-global
45 (lambda (var ctx)
46 (gen-instruction (list 'push-global var) 0 1 ctx)))
48 (define gen-set-global
49 (lambda (var ctx)
50 (gen-instruction (list 'set-global var) 1 0 ctx)))
52 (define gen-call
53 (lambda (nargs ctx)
54 (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx)))
56 (define gen-jump
57 (lambda (nargs ctx)
58 (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx)))
60 (define gen-call-toplevel
61 (lambda (nargs id ctx)
62 (gen-instruction (list 'call-toplevel id) nargs 1 ctx)))
64 (define gen-jump-toplevel
65 (lambda (nargs id ctx)
66 (gen-instruction (list 'jump-toplevel id) nargs 1 ctx)))
68 (define gen-goto
69 (lambda (label ctx)
70 (gen-instruction (list 'goto label) 0 0 ctx)))
72 (define gen-goto-if-false
73 (lambda (label-false label-true ctx)
74 (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx)))
76 (define gen-closure
77 (lambda (label-entry ctx)
78 (gen-instruction (list 'closure label-entry) 1 1 ctx)))
80 (define gen-prim
81 (lambda (id nargs unspec-result? ctx)
82 (gen-instruction
83 (list 'prim id)
84 nargs
85 (if unspec-result? 0 1)
86 ctx)))
88 (define gen-shift
89 (lambda (n ctx)
90 (if (> n 0)
91 (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx))
92 ctx)))
94 (define gen-pop
95 (lambda (ctx)
96 (gen-instruction (list 'pop) 1 0 ctx)))
98 (define gen-return
99 (lambda (ctx)
100 (let ((ss (stack-size (env-local (context-env ctx)))))
101 (gen-instruction (list 'return) ss 0 ctx))))
103 ;-----------------------------------------------------------------------------
105 (define child1
106 (lambda (node)
107 (car (node-children node))))
109 (define child2
110 (lambda (node)
111 (cadr (node-children node))))
113 (define child3
114 (lambda (node)
115 (caddr (node-children node))))
117 (define comp-none
118 (lambda (node ctx)
120 (cond ((or (cst? node)
121 (ref? node)
122 (prc? node))
123 ctx)
125 ((def? node)
126 (let ((var (def-var node)))
127 (if (toplevel-prc-with-non-rest-correct-calls? var)
128 (comp-prc (child1 node) #f ctx)
129 (if (var-needed? var)
130 (let ((ctx2 (comp-push (child1 node) ctx)))
131 (gen-set-global (var-id var) ctx2))
132 (comp-none (child1 node) ctx)))))
134 ((set? node)
135 (let ((var (set-var node)))
136 (if (var-needed? var)
137 (let ((ctx2 (comp-push (child1 node) ctx)))
138 (gen-set-global (var-id var) ctx2))
139 (comp-none (child1 node) ctx))))
141 ((if? node)
142 (let* ((ctx2
143 (context-make-label ctx))
144 (label-then
145 (context-last-label ctx2))
146 (ctx3
147 (context-make-label ctx2))
148 (label-else
149 (context-last-label ctx3))
150 (ctx4
151 (context-make-label ctx3))
152 (label-then-join
153 (context-last-label ctx4))
154 (ctx5
155 (context-make-label ctx4))
156 (label-else-join
157 (context-last-label ctx5))
158 (ctx6
159 (context-make-label ctx5))
160 (label-join
161 (context-last-label ctx6))
162 (ctx7
163 (comp-test (child1 node) label-then label-else ctx6))
164 (ctx8
165 (gen-goto
166 label-else-join
167 (comp-none (child3 node)
168 (context-change-env2
169 (context-add-bb ctx7 label-else)
170 #f))))
171 (ctx9
172 (gen-goto
173 label-then-join
174 (comp-none (child2 node)
175 (context-change-env
176 (context-add-bb ctx8 label-then)
177 (context-env2 ctx7)))))
178 (ctx10
179 (gen-goto
180 label-join
181 (context-add-bb ctx9 label-else-join)))
182 (ctx11
183 (gen-goto
184 label-join
185 (context-add-bb ctx10 label-then-join)))
186 (ctx12
187 (context-add-bb ctx11 label-join)))
188 ctx12))
190 ((call? node)
191 (comp-call node 'none ctx))
193 ((seq? node)
194 (let ((children (node-children node)))
195 (if (null? children)
196 ctx
197 (let loop ((lst children)
198 (ctx ctx))
199 (if (null? (cdr lst))
200 (comp-none (car lst) ctx)
201 (loop (cdr lst)
202 (comp-none (car lst) ctx)))))))
204 (else
205 (compiler-error "unknown expression type" node)))))
207 (define comp-tail
208 (lambda (node ctx)
210 (cond ((or (cst? node)
211 (ref? node)
212 (def? node)
213 (set? node)
214 (prc? node)
215 ; (call? node)
216 )
217 (gen-return (comp-push node ctx)))
219 ((if? node)
220 (let* ((ctx2
221 (context-make-label ctx))
222 (label-then
223 (context-last-label ctx2))
224 (ctx3
225 (context-make-label ctx2))
226 (label-else
227 (context-last-label ctx3))
228 (ctx4
229 (comp-test (child1 node) label-then label-else ctx3))
230 (ctx5
231 (comp-tail (child3 node)
232 (context-change-env2
233 (context-add-bb ctx4 label-else)
234 #f)))
235 (ctx6
236 (comp-tail (child2 node)
237 (context-change-env
238 (context-add-bb ctx5 label-then)
239 (context-env2 ctx4)))))
240 ctx6))
242 ((call? node)
243 (comp-call node 'tail ctx))
245 ((seq? node)
246 (let ((children (node-children node)))
247 (if (null? children)
248 (gen-return (gen-push-unspecified ctx))
249 (let loop ((lst children)
250 (ctx ctx))
251 (if (null? (cdr lst))
252 (comp-tail (car lst) ctx)
253 (loop (cdr lst)
254 (comp-none (car lst) ctx)))))))
256 (else
257 (compiler-error "unknown expression type" node)))))
259 (define comp-push
260 (lambda (node ctx)
262 '(
263 (display "--------------\n")
264 (pp (node->expr node))
265 (pp env)
266 (pp stk)
267 )
269 (cond ((cst? node)
270 (let ((val (cst-val node)))
271 (gen-push-constant val ctx)))
273 ((ref? node)
274 (let ((var (ref-var node)))
275 (if (var-global? var)
276 (if (null? (var-defs var))
277 (compiler-error "undefined variable:" (var-id var))
278 (let ((val (child1 (car (var-defs var)))))
279 (if (and (not (mutable-var? var))
280 (cst? val)) ;; immutable global, counted as cst
281 (gen-push-constant (cst-val val) ctx)
282 (gen-push-global (var-id var) ctx))))
283 (gen-push-local-var (var-id var) ctx))))
285 ((or (def? node)
286 (set? node))
287 (gen-push-unspecified (comp-none node ctx)))
289 ((if? node)
290 (let* ((ctx2
291 (context-make-label ctx))
292 (label-then
293 (context-last-label ctx2))
294 (ctx3
295 (context-make-label ctx2))
296 (label-else
297 (context-last-label ctx3))
298 (ctx4
299 (context-make-label ctx3))
300 (label-then-join
301 (context-last-label ctx4))
302 (ctx5
303 (context-make-label ctx4))
304 (label-else-join
305 (context-last-label ctx5))
306 (ctx6
307 (context-make-label ctx5))
308 (label-join
309 (context-last-label ctx6))
310 (ctx7
311 (comp-test (child1 node) label-then label-else ctx6))
312 (ctx8
313 (gen-goto
314 label-else-join
315 (comp-push (child3 node)
316 (context-change-env2
317 (context-add-bb ctx7 label-else)
318 #f))))
319 (ctx9
320 (gen-goto
321 label-then-join
322 (comp-push (child2 node)
323 (context-change-env
324 (context-add-bb ctx8 label-then)
325 (context-env2 ctx7)))))
326 (ctx10
327 (gen-goto
328 label-join
329 (context-add-bb ctx9 label-else-join)))
330 (ctx11
331 (gen-goto
332 label-join
333 (context-add-bb ctx10 label-then-join)))
334 (ctx12
335 (context-add-bb ctx11 label-join)))
336 ctx12))
338 ((prc? node)
339 (comp-prc node #t ctx))
341 ((call? node)
342 (comp-call node 'push ctx))
344 ((seq? node)
345 (let ((children (node-children node)))
346 (if (null? children)
347 (gen-push-unspecified ctx)
348 (let loop ((lst children)
349 (ctx ctx))
350 (if (null? (cdr lst))
351 (comp-push (car lst) ctx)
352 (loop (cdr lst)
353 (comp-none (car lst) ctx)))))))
355 (else
356 (compiler-error "unknown expression type" node)))))
358 (define (build-closure label-entry vars ctx)
360 (define (build vars ctx)
361 (if (null? vars)
362 (gen-push-constant '() ctx)
363 (gen-prim '#%cons
364 2
365 #f
366 (build (cdr vars)
367 (gen-push-local-var (car vars) ctx)))))
369 (if (null? vars)
370 (gen-closure label-entry
371 (gen-push-constant '() ctx))
372 (gen-closure label-entry
373 (build vars ctx))))
375 (define comp-prc
376 (lambda (node closure? ctx)
377 (let* ((ctx2
378 (context-make-label ctx))
379 (label-entry
380 (context-last-label ctx2))
381 (ctx3
382 (context-make-label ctx2))
383 (label-continue
384 (context-last-label ctx3))
385 (body-env
386 (prc->env node))
387 (ctx4
388 (if closure?
389 (build-closure label-entry (env-closed body-env) ctx3)
390 ctx3))
391 (ctx5
392 (gen-goto label-continue ctx4))
393 (ctx6
394 (gen-entry (length (prc-params node))
395 (prc-rest? node)
396 (context-add-bb (context-change-env ctx5
397 body-env)
398 label-entry)))
399 (ctx7
400 (comp-tail (child1 node) ctx6)))
401 (prc-entry-label-set! node label-entry)
402 (context-add-bb (context-change-env ctx7 (context-env ctx5))
403 label-continue))))
405 (define comp-call
406 (lambda (node reason ctx)
407 (let* ((op (child1 node))
408 (args (cdr (node-children node)))
409 (nargs (length args)))
410 (let loop ((lst args)
411 (ctx ctx))
412 (if (pair? lst)
414 (let ((arg (car lst)))
415 (loop (cdr lst)
416 (comp-push arg ctx)))
418 (cond ((and (ref? op)
419 (var-primitive (ref-var op)))
420 (let* ((var (ref-var op))
421 (id (var-id var))
422 (primitive (var-primitive var))
423 (prim-nargs (primitive-nargs primitive)))
425 (define use-result
426 (lambda (ctx2)
427 (cond ((eq? reason 'tail)
428 (gen-return
429 (if (primitive-unspecified-result? primitive)
430 (gen-push-unspecified ctx2)
431 ctx2)))
432 ((eq? reason 'push)
433 (if (primitive-unspecified-result? primitive)
434 (gen-push-unspecified ctx2)
435 ctx2))
436 (else
437 (if (primitive-unspecified-result? primitive)
438 ctx2
439 (gen-pop ctx2))))))
441 (use-result
442 (if (primitive-inliner primitive)
443 ((primitive-inliner primitive) ctx)
444 (if
445 (not (= nargs prim-nargs))
446 (compiler-error
447 "primitive called with wrong number of arguments"
448 id)
449 (gen-prim
450 id
451 prim-nargs
452 (primitive-unspecified-result? primitive)
453 ctx))))))
456 ((and (ref? op)
457 (toplevel-prc-with-non-rest-correct-calls?
458 (ref-var op)))
459 =>
460 (lambda (prc)
461 (cond ((eq? reason 'tail)
462 (gen-jump-toplevel nargs prc ctx))
463 ((eq? reason 'push)
464 (gen-call-toplevel nargs prc ctx))
465 (else
466 (gen-pop (gen-call-toplevel nargs prc ctx))))))
468 (else
469 (let ((ctx2 (comp-push op ctx)))
470 (cond ((eq? reason 'tail)
471 (gen-jump nargs ctx2))
472 ((eq? reason 'push)
473 (gen-call nargs ctx2))
474 (else
475 (gen-pop (gen-call nargs ctx2))))))))))))
477 (define comp-test
478 (lambda (node label-true label-false ctx)
479 (cond ((cst? node)
480 (let ((ctx2
481 (gen-goto
482 (let ((val (cst-val node)))
483 (if val
484 label-true
485 label-false))
486 ctx)))
487 (context-change-env2 ctx2 (context-env ctx2))))
489 ((or (ref? node)
490 (def? node)
491 (set? node)
492 (if? node)
493 (call? node)
494 (seq? node))
495 (let* ((ctx2
496 (comp-push node ctx))
497 (ctx3
498 (gen-goto-if-false label-false label-true ctx2)))
499 (context-change-env2 ctx3 (context-env ctx3))))
501 ((prc? node)
502 (let ((ctx2
503 (gen-goto label-true ctx)))
504 (context-change-env2 ctx2 (context-env ctx2))))
506 (else
507 (compiler-error "unknown expression type" node)))))
509 ;-----------------------------------------------------------------------------
511 (define toplevel-prc?
512 (lambda (var)
513 (and (not (mutable-var? var))
514 (let ((d (var-defs var)))
515 (and (pair? d)
516 (null? (cdr d))
517 (let ((val (child1 (car d))))
518 (and (prc? val)
519 val)))))))
521 (define toplevel-prc-with-non-rest-correct-calls?
522 (lambda (var)
523 (let ((prc (toplevel-prc? var)))
524 (and prc
525 (not (prc-rest? prc))
526 (every (lambda (r)
527 (let ((parent (node-parent r)))
528 (and (call? parent)
529 (eq? (child1 parent) r)
530 (= (length (prc-params prc))
531 (- (length (node-children parent)) 1)))))
532 (var-refs var))
533 prc))))
535 (define mutable-var?
536 (lambda (var)
537 (not (null? (var-sets var)))))
539 (define global-fv
540 (lambda (node)
541 (list->varset
542 (keep var-global?
543 (varset->list (fv node))))))
545 (define non-global-fv
546 (lambda (node)
547 (list->varset
548 (keep (lambda (x) (not (var-global? x)))
549 (varset->list (fv node))))))
551 (define fv
552 (lambda (node)
553 (cond ((cst? node)
554 (varset-empty))
555 ((ref? node)
556 (let ((var (ref-var node)))
557 (varset-singleton var)))
558 ((def? node)
559 (let ((var (def-var node))
560 (val (child1 node)))
561 (varset-union
562 (varset-singleton var)
563 (fv val))))
564 ((set? node)
565 (let ((var (set-var node))
566 (val (child1 node)))
567 (varset-union
568 (varset-singleton var)
569 (fv val))))
570 ((if? node)
571 (let ((a (list-ref (node-children node) 0))
572 (b (list-ref (node-children node) 1))
573 (c (list-ref (node-children node) 2)))
574 (varset-union-multi (list (fv a) (fv b) (fv c)))))
575 ((prc? node)
576 (let ((body (list-ref (node-children node) 0)))
577 (varset-difference
578 (fv body)
579 (build-params-varset (prc-params node)))))
580 ((call? node)
581 (varset-union-multi (map fv (node-children node))))
582 ((seq? node)
583 (varset-union-multi (map fv (node-children node))))
584 (else
585 (compiler-error "unknown expression type" node)))))
587 (define build-params-varset
588 (lambda (params)
589 (list->varset params)))
591 (define mark-needed-global-vars!
592 (lambda (global-env node)
594 (define readyq
595 (env-lookup global-env '#%readyq))
597 (define mark-var!
598 (lambda (var)
599 (if (and (var-global? var)
600 (not (var-needed? var))
601 ;; globals that obey the following conditions are considered
602 ;; to be constants
603 (not (and (not (mutable-var? var))
604 ;; to weed out primitives, which have no definitions
605 (> (length (var-defs var)) 0)
606 (cst? (child1 (car (var-defs var)))))))
607 (begin
608 (var-needed?-set! var #t)
609 (for-each
610 (lambda (def)
611 (let ((val (child1 def)))
612 (if (side-effect-less? val)
613 (mark! val))))
614 (var-defs var))
615 (if (eq? var readyq)
616 (begin
617 (mark-var!
618 (env-lookup global-env '#%start-first-process))
619 (mark-var!
620 (env-lookup global-env '#%exit))))))))
622 (define side-effect-less?
623 (lambda (node)
624 (or (cst? node)
625 (ref? node)
626 (prc? node))))
628 (define mark!
629 (lambda (node)
630 (cond ((cst? node))
631 ((ref? node)
632 (let ((var (ref-var node)))
633 (mark-var! var)))
634 ((def? node)
635 (let ((var (def-var node))
636 (val (child1 node)))
637 (if (not (side-effect-less? val))
638 (mark! val))))
639 ((set? node)
640 (let ((var (set-var node))
641 (val (child1 node)))
642 (mark! val)))
643 ((if? node)
644 (let ((a (list-ref (node-children node) 0))
645 (b (list-ref (node-children node) 1))
646 (c (list-ref (node-children node) 2)))
647 (mark! a)
648 (mark! b)
649 (mark! c)))
650 ((prc? node)
651 (let ((body (list-ref (node-children node) 0)))
652 (mark! body)))
653 ((call? node)
654 (for-each mark! (node-children node)))
655 ((seq? node)
656 (for-each mark! (node-children node)))
657 (else
658 (compiler-error "unknown expression type" node)))))
660 (mark! node)
661 ))
663 ;-----------------------------------------------------------------------------
665 ;; Variable sets
667 (define (varset-empty) ; return the empty set
668 '())
670 (define (varset-singleton x) ; create a set containing only 'x'
671 (list x))
673 (define (list->varset lst) ; convert list to set
674 lst)
676 (define (varset->list set) ; convert set to list
677 set)
679 (define (varset-size set) ; return cardinality of set
680 (list-length set))
682 (define (varset-empty? set) ; is 'x' the empty set?
683 (null? set))
685 (define (varset-member? x set) ; is 'x' a member of the 'set'?
686 (and (not (null? set))
687 (or (eq? x (car set))
688 (varset-member? x (cdr set)))))
690 (define (varset-adjoin set x) ; add the element 'x' to the 'set'
691 (if (varset-member? x set) set (cons x set)))
693 (define (varset-remove set x) ; remove the element 'x' from 'set'
694 (cond ((null? set)
695 '())
696 ((eq? (car set) x)
697 (cdr set))
698 (else
699 (cons (car set) (varset-remove (cdr set) x)))))
701 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
702 (and (varset-subset? s1 s2)
703 (varset-subset? s2 s1)))
705 (define (varset-subset? s1 s2) ; is 's1' a subset of 's2'?
706 (cond ((null? s1)
707 #t)
708 ((varset-member? (car s1) s2)
709 (varset-subset? (cdr s1) s2))
710 (else
711 #f)))
713 (define (varset-difference set1 set2) ; return difference of sets
714 (cond ((null? set1)
715 '())
716 ((varset-member? (car set1) set2)
717 (varset-difference (cdr set1) set2))
718 (else
719 (cons (car set1) (varset-difference (cdr set1) set2)))))
721 (define (varset-union set1 set2) ; return union of sets
722 (define (union s1 s2)
723 (cond ((null? s1)
724 s2)
725 ((varset-member? (car s1) s2)
726 (union (cdr s1) s2))
727 (else
728 (cons (car s1) (union (cdr s1) s2)))))
729 (if (varset-smaller? set1 set2)
730 (union set1 set2)
731 (union set2 set1)))
733 (define (varset-intersection set1 set2) ; return intersection of sets
734 (define (intersection s1 s2)
735 (cond ((null? s1)
736 '())
737 ((varset-member? (car s1) s2)
738 (cons (car s1) (intersection (cdr s1) s2)))
739 (else
740 (intersection (cdr s1) s2))))
741 (if (varset-smaller? set1 set2)
742 (intersection set1 set2)
743 (intersection set2 set1)))
745 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
746 (not (varset-empty? (varset-intersection set1 set2))))
748 (define (varset-smaller? set1 set2)
749 (if (null? set1)
750 (not (null? set2))
751 (if (null? set2)
752 #f
753 (varset-smaller? (cdr set1) (cdr set2)))))
755 (define (varset-union-multi sets)
756 (if (null? sets)
757 (varset-empty)
758 (n-ary varset-union (car sets) (cdr sets))))
760 (define (n-ary function first rest)
761 (if (null? rest)
762 first
763 (n-ary function (function first (car rest)) (cdr rest))))
765 ;------------------------------------------------------------------------------
767 (define code->vector
768 (lambda (code)
769 (let ((v (make-vector (+ (code-last-label code) 1))))
770 (for-each
771 (lambda (bb)
772 (vector-set! v (bb-label bb) bb))
773 (code-rev-bbs code))
774 v)))
776 (define bbs->ref-counts
777 (lambda (bbs)
778 (let ((ref-counts (make-vector (vector-length bbs) 0)))
780 (define visit
781 (lambda (label)
782 (let ((ref-count (vector-ref ref-counts label)))
783 (vector-set! ref-counts label (+ ref-count 1))
784 (if (= ref-count 0)
785 (let* ((bb (vector-ref bbs label))
786 (rev-instrs (bb-rev-instrs bb)))
787 (for-each
788 (lambda (instr)
789 (let ((opcode (car instr)))
790 (cond ((eq? opcode 'goto)
791 (visit (cadr instr)))
792 ((eq? opcode 'goto-if-false)
793 (visit (cadr instr))
794 (visit (caddr instr)))
795 ((or (eq? opcode 'closure)
796 (eq? opcode 'call-toplevel)
797 (eq? opcode 'jump-toplevel))
798 (visit (cadr instr))))))
799 rev-instrs))))))
801 (visit 0)
803 ref-counts)))
805 (define resolve-toplevel-labels!
806 (lambda (bbs)
807 (let loop ((i 0))
808 (if (< i (vector-length bbs))
809 (let* ((bb (vector-ref bbs i))
810 (rev-instrs (bb-rev-instrs bb)))
811 (bb-rev-instrs-set!
812 bb
813 (map (lambda (instr)
814 (let ((opcode (car instr)))
815 (cond ((eq? opcode 'call-toplevel)
816 (list opcode
817 (prc-entry-label (cadr instr))))
818 ((eq? opcode 'jump-toplevel)
819 (list opcode
820 (prc-entry-label (cadr instr))))
821 (else
822 instr))))
823 rev-instrs))
824 (loop (+ i 1)))))))
826 (define tighten-jump-cascades!
827 (lambda (bbs)
828 (let ((ref-counts (bbs->ref-counts bbs)))
830 (define resolve
831 (lambda (label)
832 (let* ((bb (vector-ref bbs label))
833 (rev-instrs (bb-rev-instrs bb)))
834 (and (or (null? (cdr rev-instrs))
835 (= (vector-ref ref-counts label) 1))
836 rev-instrs))))
838 (let loop1 ()
839 (let loop2 ((i 0)
840 (changed? #f))
841 (if (< i (vector-length bbs))
842 (if (> (vector-ref ref-counts i) 0)
843 (let* ((bb (vector-ref bbs i))
844 (rev-instrs (bb-rev-instrs bb))
845 (jump (car rev-instrs))
846 (opcode (car jump)))
847 (cond ((eq? opcode 'goto)
848 (let* ((label (cadr jump))
849 (jump-replacement (resolve label)))
850 (if jump-replacement
851 (begin
852 (vector-set!
853 bbs
854 i
855 (make-bb (bb-label bb)
856 (append jump-replacement
857 (cdr rev-instrs))))
858 (loop2 (+ i 1)
859 #t))
860 (loop2 (+ i 1)
861 changed?))))
862 ((eq? opcode 'goto-if-false)
863 (let* ((label-then (cadr jump))
864 (label-else (caddr jump))
865 (jump-then-replacement (resolve label-then))
866 (jump-else-replacement (resolve label-else)))
867 (if (and jump-then-replacement
868 (null? (cdr jump-then-replacement))
869 jump-else-replacement
870 (null? (cdr jump-else-replacement))
871 (or (eq? (caar jump-then-replacement)
872 'goto)
873 (eq? (caar jump-else-replacement)
874 'goto)))
875 (begin
876 (vector-set!
877 bbs
878 i
879 (make-bb
880 (bb-label bb)
881 (cons
882 (list
883 'goto-if-false
884 (if (eq? (caar jump-then-replacement)
885 'goto)
886 (cadar jump-then-replacement)
887 label-then)
888 (if (eq? (caar jump-else-replacement)
889 'goto)
890 (cadar jump-else-replacement)
891 label-else))
892 (cdr rev-instrs))))
893 (loop2 (+ i 1)
894 #t))
895 (loop2 (+ i 1)
896 changed?))))
897 (else
898 (loop2 (+ i 1)
899 changed?))))
900 (loop2 (+ i 1)
901 changed?))
902 (if changed?
903 (loop1))))))))
905 (define remove-useless-bbs!
906 (lambda (bbs)
907 (let ((ref-counts (bbs->ref-counts bbs)))
908 (let loop1 ((label 0) (new-label 0))
909 (if (< label (vector-length bbs))
910 (if (> (vector-ref ref-counts label) 0)
911 (let ((bb (vector-ref bbs label)))
912 (vector-set!
913 bbs
914 label
915 (make-bb new-label (bb-rev-instrs bb)))
916 (loop1 (+ label 1) (+ new-label 1)))
917 (loop1 (+ label 1) new-label))
918 (renumber-labels bbs ref-counts new-label))))))
920 (define renumber-labels
921 (lambda (bbs ref-counts n)
922 (let ((new-bbs (make-vector n)))
923 (let loop2 ((label 0))
924 (if (< label (vector-length bbs))
925 (if (> (vector-ref ref-counts label) 0)
926 (let* ((bb (vector-ref bbs label))
927 (new-label (bb-label bb))
928 (rev-instrs (bb-rev-instrs bb)))
930 (define fix
931 (lambda (instr)
933 (define new-label
934 (lambda (label)
935 (bb-label (vector-ref bbs label))))
937 (let ((opcode (car instr)))
938 (cond ((eq? opcode 'closure)
939 (list 'closure
940 (new-label (cadr instr))))
941 ((eq? opcode 'call-toplevel)
942 (list 'call-toplevel
943 (new-label (cadr instr))))
944 ((eq? opcode 'jump-toplevel)
945 (list 'jump-toplevel
946 (new-label (cadr instr))))
947 ((eq? opcode 'goto)
948 (list 'goto
949 (new-label (cadr instr))))
950 ((eq? opcode 'goto-if-false)
951 (list 'goto-if-false
952 (new-label (cadr instr))
953 (new-label (caddr instr))))
954 (else
955 instr)))))
957 (vector-set!
958 new-bbs
959 new-label
960 (make-bb new-label (map fix rev-instrs)))
961 (loop2 (+ label 1)))
962 (loop2 (+ label 1)))
963 new-bbs)))))
965 (define reorder!
966 (lambda (bbs)
967 (let* ((done (make-vector (vector-length bbs) #f)))
969 (define unscheduled?
970 (lambda (label)
971 (not (vector-ref done label))))
973 (define label-refs
974 (lambda (instrs todo)
975 (if (pair? instrs)
976 (let* ((instr (car instrs))
977 (opcode (car instr)))
978 (cond ((or (eq? opcode 'closure)
979 (eq? opcode 'call-toplevel)
980 (eq? opcode 'jump-toplevel))
981 (label-refs (cdr instrs) (cons (cadr instr) todo)))
982 (else
983 (label-refs (cdr instrs) todo))))
984 todo)))
986 (define schedule-here
987 (lambda (label new-label todo cont)
988 (let* ((bb (vector-ref bbs label))
989 (rev-instrs (bb-rev-instrs bb))
990 (jump (car rev-instrs))
991 (opcode (car jump))
992 (new-todo (label-refs rev-instrs todo)))
993 (vector-set! bbs label (make-bb new-label rev-instrs))
994 (vector-set! done label #t)
995 (cond ((eq? opcode 'goto)
996 (let ((label (cadr jump)))
997 (if (unscheduled? label)
998 (schedule-here label
999 (+ new-label 1)
1000 new-todo
1001 cont)
1002 (cont (+ new-label 1)
1003 new-todo))))
1004 ((eq? opcode 'goto-if-false)
1005 (let ((label-then (cadr jump))
1006 (label-else (caddr jump)))
1007 (cond ((unscheduled? label-else)
1008 (schedule-here label-else
1009 (+ new-label 1)
1010 (cons label-then new-todo)
1011 cont))
1012 ((unscheduled? label-then)
1013 (schedule-here label-then
1014 (+ new-label 1)
1015 new-todo
1016 cont))
1017 (else
1018 (cont (+ new-label 1)
1019 new-todo)))))
1020 (else
1021 (cont (+ new-label 1)
1022 new-todo))))))
1024 (define schedule-somewhere
1025 (lambda (label new-label todo cont)
1026 (schedule-here label new-label todo cont)))
1028 (define schedule-todo
1029 (lambda (new-label todo)
1030 (if (pair? todo)
1031 (let ((label (car todo)))
1032 (if (unscheduled? label)
1033 (schedule-somewhere label
1034 new-label
1035 (cdr todo)
1036 schedule-todo)
1037 (schedule-todo new-label
1038 (cdr todo)))))))
1041 (schedule-here 0 0 '() schedule-todo)
1043 (renumber-labels bbs
1044 (make-vector (vector-length bbs) 1)
1045 (vector-length bbs)))))
1047 (define linearize-old
1048 (lambda (bbs)
1049 (let loop ((label (- (vector-length bbs) 1))
1050 (lst '()))
1051 (if (>= label 0)
1052 (let* ((bb (vector-ref bbs label))
1053 (rev-instrs (bb-rev-instrs bb))
1054 (jump (car rev-instrs))
1055 (opcode (car jump)))
1056 (loop (- label 1)
1057 (append
1058 (list label)
1059 (reverse
1060 (cond ((eq? opcode 'goto)
1061 (if (= (cadr jump) (+ label 1))
1062 (cdr rev-instrs)
1063 rev-instrs))
1064 ((eq? opcode 'goto-if-false)
1065 (cond ((= (caddr jump) (+ label 1))
1066 (cons (list 'goto-if-false (cadr jump))
1067 (cdr rev-instrs)))
1068 ((= (cadr jump) (+ label 1))
1069 (cons (list 'goto-if-not-false (caddr jump))
1070 (cdr rev-instrs)))
1071 (else
1072 (cons (list 'goto (caddr jump))
1073 (cons (list 'goto-if-false (cadr jump))
1074 (cdr rev-instrs))))))
1075 (else
1076 rev-instrs)))
1077 lst)))
1078 lst))))
1080 (define linearize
1081 (lambda (bbs)
1083 (define rev-code '())
1085 (define pos 0)
1087 (define (emit x)
1088 (set! pos (+ pos 1))
1089 (set! rev-code (cons x rev-code)))
1091 (define todo (cons '() '()))
1093 (define dumped (make-vector (vector-length bbs) #f))
1095 (define (get fallthrough-to-next?)
1096 (if (pair? (cdr todo))
1097 (if fallthrough-to-next?
1098 (let* ((label-pos (cadr todo))
1099 (label (car label-pos))
1100 (rest (cddr todo)))
1101 (if (not (pair? rest))
1102 (set-car! todo todo))
1103 (set-cdr! todo rest)
1104 label)
1105 (let loop ((x (cdr todo)) (best-label-pos #f))
1106 #;
1107 (if (pair? x)
1108 (if (not (vector-ref dumped (car (car x))))
1109 (pp (car x))))
1110 (if (pair? x)
1111 (loop (cdr x)
1112 (if (vector-ref dumped (car (car x)))
1113 best-label-pos
1114 (if (or (not best-label-pos)
1115 (> (cdr (car x)) (cdr best-label-pos)))
1116 (car x)
1117 best-label-pos)))
1118 (if (pair? best-label-pos)
1119 (car best-label-pos)
1120 #f))))
1121 #f))
1123 (define (next)
1124 (let loop ((x (cdr todo)))
1125 (if (pair? x)
1126 (let* ((label-pos (car x))
1127 (label (car label-pos)))
1128 (if (not (vector-ref dumped label))
1129 label
1130 (loop (cdr x))))
1131 #f)))
1133 (define (schedule! label tail?)
1134 (let ((label-pos (cons label pos)))
1135 (if tail?
1136 (let ((cell (cons label-pos '())))
1137 (set-cdr! (car todo) cell)
1138 (set-car! todo cell))
1139 (let ((cell (cons label-pos (cdr todo))))
1140 (set-cdr! todo cell)
1141 (if (eq? (car todo) todo)
1142 (set-car! todo cell))))))
1144 (define (dump)
1145 (let loop ((fallthrough-to-next? #t))
1146 (let ((label (get fallthrough-to-next?)))
1147 (if label
1148 (if (not (vector-ref dumped label))
1149 (begin
1150 (vector-set! dumped label #t)
1151 (loop (dump-bb label)))
1152 (loop fallthrough-to-next?))))))
1154 (define (dump-bb label)
1155 (let* ((bb (vector-ref bbs label))
1156 (rev-instrs (bb-rev-instrs bb))
1157 (jump (car rev-instrs))
1158 (opcode (car jump)))
1159 (emit label)
1160 (for-each
1161 (lambda (instr)
1162 (case (car instr)
1163 ((closure call-toplevel)
1164 (schedule! (cadr instr) #t)))
1165 (emit instr))
1166 (reverse (cdr rev-instrs)))
1167 (cond ((eq? opcode 'goto)
1168 (schedule! (cadr jump) #f)
1169 (if (not (equal? (cadr jump) (next)))
1170 (begin
1171 (emit jump)
1172 #f)
1173 #t))
1174 ((eq? opcode 'goto-if-false)
1175 (schedule! (cadr jump) #f)
1176 (schedule! (caddr jump) #f)
1177 (cond ((equal? (caddr jump) (next))
1178 (emit (list 'goto-if-false (cadr jump)))
1179 #t)
1180 ((equal? (cadr jump) (next))
1181 (emit (list 'prim '#%not))
1182 (emit (list 'goto-if-false (caddr jump)))
1183 #t)
1184 (else
1185 (emit (list 'goto-if-false (cadr jump)))
1186 (emit (list 'goto (caddr jump)))
1187 #f)))
1188 (else
1189 (case (car jump)
1190 ((jump-toplevel)
1191 (schedule! (cadr jump) #f)
1192 ;; it is not correct to remove jump-toplevel when label is next
1193 (if #t ;; (not (equal? (cadr jump) (next)))
1194 (begin
1195 (emit jump)
1196 #f)
1197 #t))
1198 (else
1199 (emit jump)
1200 #f))))))
1202 (set-car! todo todo) ;; make fifo
1204 (schedule! 0 #f)
1206 (dump)
1208 (reverse rev-code)))
1210 (define optimize-code
1211 (lambda (code)
1212 (let ((bbs (code->vector code)))
1213 (resolve-toplevel-labels! bbs)
1214 (tighten-jump-cascades! bbs)
1215 (let ((bbs (remove-useless-bbs! bbs)))
1216 (reorder! bbs)))))