From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Wed, 30 Dec 1992 14:13:45 +0000 (+0000)
Subject: Changes for the C back end.
X-Git-Tag: 20090517-FFI~8632
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ab8d88f01f73ce99fd3cbf1f21c8abb662b3deb8;p=mit-scheme.git

Changes for the C back end.
---

diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm
index f291f32e3..712a66750 100644
--- a/v7/src/compiler/back/lapgn1.scm
+++ b/v7/src/compiler/back/lapgn1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: lapgn1.scm,v 4.13 1992/10/24 16:01:03 jinx Exp $
+$Id: lapgn1.scm,v 4.14 1992/12/30 14:13:35 gjr Exp $
 
 Copyright (c) 1987-1992 Massachusetts Institute of Technology
 
@@ -48,33 +48,60 @@ MIT in each case. |#
     (with-new-node-marks
       (lambda ()
 	(for-each cgen-rgraph rgraphs)
-	(for-each (lambda (remote-link)
-		    (vector-set! remote-link
-				 0
-				 (constant->label (vector-ref remote-link 0)))
-		    unspecific)
-		  remote-links)
-	(with-values prepare-constants-block
-	  (or process-constants-block
-	      (lambda (constants-code environment-label free-ref-label
-				      n-sections)
-		(LAP ,@constants-code
-		     ,@(generate/quotation-header environment-label
-						  (or free-ref-label
-						      environment-label)
-						  n-sections)
-		     ,@(let loop ((remote-links remote-links))
-			 (if (null? remote-links)
-			     (LAP)
-			     (LAP ,@(let ((remote-link (car remote-links)))
-				      (generate/remote-link
-				       (vector-ref remote-link 0)
-				       (vector-ref remote-link 1)
-				       (or (vector-ref remote-link 2)
-					   (vector-ref remote-link 1))
-				       (vector-ref remote-link 3)))
-				  ,@(loop (cdr remote-links)))))))))))))
+	(let ((link-info
+	       (and compiler:compress-top-level?
+		    (not (null? remote-links))
+		    (not (null? (cdr remote-links)))
+		    (let* ((index->vector
+			    (lambda (index)
+			      (list->vector
+			       (map (lambda (remote-link)
+				      (vector-ref remote-link index))
+				    remote-links))))
+			   (index->constant-label
+			    (lambda (index)
+			      (constant->label (index->vector index)))))
+		      (list (length remote-links)
+			    ;; cc blocks
+			    (index->constant-label 0)
+			    ;; number of linker sections
+			    (index->vector 3))))))
 
+	  (if (not link-info)
+	      (for-each (lambda (remote-link)
+			  (vector-set! remote-link
+				       0
+				       (constant->label
+					(vector-ref remote-link 0)))
+			  unspecific)
+			remote-links))
+	    
+	  (with-values prepare-constants-block
+	    (or process-constants-block
+		(lambda (constants-code environment-label free-ref-label
+					n-sections)
+		  (LAP ,@constants-code
+		       ,@(generate/quotation-header environment-label
+						    (or free-ref-label
+							environment-label)
+						    n-sections)
+		       ,@(if link-info
+			     (generate/remote-links (car link-info)
+						    (cadr link-info)
+						    (caddr link-info))
+			     (let loop ((remote-links remote-links))
+			       (if (null? remote-links)
+				   (LAP)
+				   (LAP
+				    ,@(let ((remote-link (car remote-links)))
+					(generate/remote-link
+					 (vector-ref remote-link 0)
+					 (vector-ref remote-link 1)
+					 (or (vector-ref remote-link 2)
+					     (vector-ref remote-link 1))
+					 (vector-ref remote-link 3)))
+				    ,@(loop (cdr remote-links)))))))))))))))
+
 (define (cgen-rgraph rgraph)
   (fluid-let ((*current-rgraph* rgraph)
 	      (*pending-bblocks* '()))
@@ -84,7 +111,7 @@ MIT in each case. |#
 	      (rgraph-entry-edges rgraph))
     (if (not (null? *pending-bblocks*))
 	(error "CGEN-RGRAPH: pending blocks left at end of pass"))))
-
+
 (define (cgen-entry rgraph edge)
   (define (loop bblock map)
     (cgen-bblock bblock map)
diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm
index 2d1b4c2ab..9ce0b0587 100644
--- a/v7/src/compiler/rtlgen/opncod.scm
+++ b/v7/src/compiler/rtlgen/opncod.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: opncod.scm,v 4.55 1992/12/28 21:57:56 cph Exp $
+$Id: opncod.scm,v 4.56 1992/12/30 14:13:45 gjr Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -278,11 +278,14 @@ MIT in each case. |#
 		    internal-close-coding?)
 	    (values false false false))))))
 
+(define-integrable scheme-type-limit
+  (back-end:expt 2 scheme-type-width))
+
 (define filter/type-code
   (constant-filter
    (lambda (operand)
      (and (exact-nonnegative-integer? operand)
-	  (< operand (expt 2 scheme-type-width))))))
+	  (back-end:< operand scheme-type-limit)))))
 
 (define (internal-close-coding-for-type-checks)
   compiler:generate-type-checks?)
@@ -590,7 +593,7 @@ MIT in each case. |#
 			(rtl:constant-value type))))
 	 (if (and ok?
 		  (exact-nonnegative-integer? tag)
-		  (< tag (expt 2 scheme-type-width)))
+		  (back-end:< tag scheme-type-limit))
 	     (finish
 	      (rtl:make-type-test (rtl:make-object->type object)
 				  tag))
@@ -600,7 +603,7 @@ MIT in each case. |#
 	       (open-code:type-check type (ucode-type fixnum))
 	       (open-code:range-check type
 				      (rtl:make-machine-constant
-				       (expt 2 scheme-type-width))))
+				       scheme-type-limit)))
 	      (finish
 	       (rtl:make-eq-test (rtl:make-object->datum type)
 				 (rtl:make-object->type object)))