Tuning to increase performance.

diff --git a/v7/src/compiler/back/linear.scm b/v7/src/compiler/back/linear.scm
index e1d45c487189e94b06699cf7fb304d48a8ab1db9..12db4faaed4c8084a12d8782fb1af17ad93aebce 100644 (file)
--- a/v7/src/compiler/back/linear.scm
+++ b/v7/src/compiler/back/linear.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.4 1988/09/15 05:05:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.5 1988/09/15 08:39:07 cph Exp $
 
 Copyright (c) 1987, 1988 Massachusetts Institute of Technology
 
@@ -62,25 +62,23 @@ MIT in each case. |#
     (cond ((not bblock)
           (LAP))
          ((node-marked? bblock)
-          (LAP ,(lap:make-unconditional-branch (get-bblock-label bblock))))
+          (LAP ,(lap:make-unconditional-branch (bblock-label bblock))))
          (else
           (linearize-bblock bblock))))
 
   (define (linearize-pblock pblock cn an)
     (if (node-marked? cn)
-       (let ((clabel (get-bblock-label cn)))
-         (if (node-marked? an)
-             (let ((alabel (get-bblock-label an)))
-               (LAP ,@((pblock-consequent-lap-generator pblock) clabel)
-                    ,(lap:make-unconditional-branch alabel)))
-             (LAP ,@((pblock-consequent-lap-generator pblock) clabel)
-                  ,@(linearize-bblock an))))
        (if (node-marked? an)
-           (let ((alabel (get-bblock-label an)))
-             (LAP ,@((pblock-alternative-lap-generator pblock) alabel)
-                  ,@(linearize-bblock cn)))
-           (let* ((clabel (bblock-label! cn))
-                  (alternative (linearize-bblock an)))
+           (LAP ,@((pblock-consequent-lap-generator pblock) (bblock-label cn))
+                ,(lap:make-unconditional-branch (bblock-label an)))
+           (LAP ,@((pblock-consequent-lap-generator pblock) (bblock-label cn))
+                ,@(linearize-bblock an)))
+       (if (node-marked? an)
+           (LAP ,@((pblock-alternative-lap-generator pblock)
+                   (bblock-label an))
+                ,@(linearize-bblock cn))
+           (let ((clabel (bblock-label! cn))
+                 (alternative (linearize-bblock an)))
              (LAP ,@((pblock-consequent-lap-generator pblock) clabel)
                   ,@alternative
                   ,@(if (node-marked? cn)
@@ -89,10 +87,6 @@ MIT in each case. |#
 
   (linearize-bblock bblock))
 
-(define (get-bblock-label bblock)
-  (or (bblock-label bblock)
-      (error "GET-BBLOCK-LABEL: block not labeled" bblock)))
-
 (define linearize-bits
   (make-linearizer bblock-linearize-bits
     (lambda () (LAP))

diff --git a/v7/src/compiler/rtlbase/rtline.scm b/v7/src/compiler/rtlbase/rtline.scm
index 82ee60edc18781fd8f81be7695e1a04c36967b21..0eb474acf9841af27d57e0c787c1a2b2d2e6928a 100644 (file)
--- a/v7/src/compiler/rtlbase/rtline.scm
+++ b/v7/src/compiler/rtlbase/rtline.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.5 1988/09/15 05:05:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.6 1988/09/15 08:41:06 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -49,17 +49,17 @@ MIT in each case. |#
        (let ((queue-continuations!
              (lambda (bblock)
                (for-each (lambda (bblock)
-                           (enqueue!/unsafe input-queue bblock))
+                           (if (not (node-marked? bblock))
+                               (enqueue!/unsafe input-queue bblock)))
                          (bblock-continuations bblock)))))
         (let ((process-bblock!
                (lambda (bblock)
                  (if (not (node-marked? bblock))
-                     (begin
-                       (set! output
-                             (instruction-append!
-                              output
-                              (bblock-linearize bblock
-                                                queue-continuations!))))))))
+                     (set! output
+                           (instruction-append!
+                            output
+                            (bblock-linearize bblock
+                                              queue-continuations!)))))))
           (process-bblock! (rtl-expr/entry-node expression))      (queue-map!/unsafe input-queue process-bblock!)
           (for-each (lambda (procedure)
                       (process-bblock! (rtl-procedure/entry-node procedure))
@@ -75,14 +75,27 @@ MIT in each case. |#
        (let ((continuations '()))
          (bblock-walk-forward bblock
            (lambda (rinst)
-             (for-each (lambda (continuation)
-                         (if (not (memq continuation continuations))
-                             (set! continuations
-                                   (cons continuation continuations))))
-                       (rtl:continuations-mentioned (rinst-rtl rinst)))))
-         (set-bblock-continuations! bblock
-                                    (map label->continuation-entry
-                                         continuations)))
+             (let loop ((expression (cdr (rinst-rtl rinst))))
+               (if (pair? expression)
+                   (cond ((eq? (car expression) 'ENTRY:CONTINUATION)
+                          ;; Because the average number of
+                          ;; continuations per basic block is usually
+                          ;; less than one, we optimize this case to
+                          ;; speed up the accumulation.
+                          (cond ((null? continuations)
+                                 (set! continuations
+                                       (list (cadr expression))))
+                                ((not (memq (cadr expression) continuations))
+                                 (set! continuations
+                                       (cons (cadr expression)
+                                             continuations)))))
+                         ((not (eq? (car expression) 'CONSTANT))
+                          (for-each loop (cdr expression))))))))
+         (set-bblock-continuations!
+          bblock
+          (map (lambda (label)
+                 (rtl-continuation/entry-node (label->object label)))
+               continuations)))
        (if (sblock? bblock)
            (let ((rtl (rinst-rtl (rinst-last (bblock-instructions bblock)))))
              (if (rtl:invocation? rtl)
@@ -90,25 +103,10 @@ MIT in each case. |#
                    (if continuation
                        (set-sblock-continuation!
                         bblock
-                        (label->continuation-entry continuation))))))))
+                        (rtl-continuation/entry-node
+                         (label->object continuation)))))))))
       (rgraph-bblocks rgraph)))
    rgraphs))
-
-(define-integrable (label->continuation-entry label)
-  (rtl-continuation/entry-node (label->object label)))
-
-(define (rtl:continuations-mentioned rtl)
-  (define (loop expression)
-    (if (pair? expression)
-       (case (car expression)
-         ((CONSTANT)
-          '())
-         ((ENTRY:CONTINUATION)
-          (list (cadr expression)))
-         (else
-          (mapcan loop (cdr expression))))
-       '()))
-  (mapcan loop (cdr rtl)))
 \f
 ;;; The linearizer attaches labels to nodes under two conditions.  The
 ;;; first is that the node in question has more than one previous
@@ -150,28 +148,25 @@ MIT in each case. |#
     (cond ((not sblock)
           '())
          ((node-marked? sblock)
-          `(,(rtl:make-jump-statement (get-bblock-label sblock))))
+          `(,(rtl:make-jump-statement (bblock-label sblock))))
          (else
           (linearize-bblock sblock))))
 
   (define (linearize-pblock pblock predicate cn an)
     pblock
     (if (node-marked? cn)
-       (let ((clabel (get-bblock-label cn)))
-         (if (node-marked? an)
-             (let ((alabel (get-bblock-label an)))
-               `(,(rtl:make-jumpc-statement predicate clabel)
-                 ,(rtl:make-jump-statement alabel)))
-             `(,(rtl:make-jumpc-statement predicate clabel)
-               ,@(linearize-bblock an))))
        (if (node-marked? an)
-           (let ((alabel (get-bblock-label an)))
-             `(,(rtl:make-jumpc-statement (rtl:negate-predicate predicate)
-                                          alabel)
-               ,@(linearize-bblock cn)))
-           (let* ((label (bblock-label! cn))
+           `(,(rtl:make-jumpc-statement predicate (bblock-label cn))
+             ,(rtl:make-jump-statement (bblock-label an)))
+           `(,(rtl:make-jumpc-statement predicate (bblock-label cn))
+             ,@(linearize-bblock an)))
+       (if (node-marked? an)
+           `(,(rtl:make-jumpc-statement (rtl:negate-predicate predicate)
+                                        (bblock-label an))
+             ,@(linearize-bblock cn))
+           (let ((clabel (bblock-label! cn))
                   (alternative (linearize-bblock an)))
-             `(,(rtl:make-jumpc-statement predicate label)
+             `(,(rtl:make-jumpc-statement predicate clabel)
                ,@alternative
                ,@(if (node-marked? cn)
                      '()
@@ -179,10 +174,6 @@ MIT in each case. |#
 
   (linearize-bblock bblock))
 
-(define (get-bblock-label bblock)
-  (or (bblock-label bblock)
-      (error "GET-BBLOCK-LABEL: block not labeled" bblock)))
-
 (define linearize-rtl
   (make-linearizer bblock-linearize-rtl
     (lambda ()