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