Changes for the C back end.

diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm
index f291f32e3eaff0a4dc6aacf0e6ad0f5f2c7557cd..712a6675082599691e8db7c0c67a5eff9f1bab59 100644 (file)
--- 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)))))))))))))))
+\f
 (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"))))
-\f
+
 (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 2d1b4c2abc2154fad4a5bd047e3b9c8de2fefd7e..9ce0b0587af92cde39e3d8728961ff65542c7c9b 100644 (file)
--- 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)))