From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 15 Sep 1988 08:41:06 +0000 (+0000)
Subject: Tuning to increase performance.
X-Git-Tag: 20090517-FFI~12534
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=efae6b7f4b2fcafdc70b608a2b6978dc8396a844;p=mit-scheme.git

Tuning to increase performance.
---

diff --git a/v7/src/compiler/back/linear.scm b/v7/src/compiler/back/linear.scm
index e1d45c487..12db4faae 100644
--- 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 82ee60edc..0eb474acf 100644
--- 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)))
 
 ;;; 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 ()