Reimplement 32 bit offsets in compiled code blocks. They are now

implemented as a chain of 16 bit offsets, since parts of the system
depend on the fact that any given offset is only 16 bits long.

diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm
index 245bfcce17a3dd98ac31108a3788a71bdfcb559b..66be6b037f875eca0f6cb2ea0a6017e2fb0755b1 100644 (file)
--- a/v7/src/compiler/back/bittop.scm
+++ b/v7/src/compiler/back/bittop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.4 1987/07/30 07:05:13 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.5 1987/07/30 21:26:59 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -140,12 +140,23 @@ MIT in each case. |#
 \f
 (define (assemble-directives! block directives block-length)
 
-  (define (loop directives dir-stack pc pc-stack position)
+  (define (loop directives dir-stack pc pc-stack position last-blabel blabel)
 
     (define (actual-bits bits l)
       (let ((np (- position l)))
        (bit-string-insert! bits block np)
-       (loop (cdr directives) dir-stack (+ pc l) pc-stack np)))
+       (loop (cdr directives) dir-stack (+ pc l) pc-stack np
+             last-blabel blabel)))
+
+    (define (block-offset offset last-blabel blabel)
+      (let ((np (- position block-offset-width)))
+       (bit-string-insert!
+        (block-offset->bit-string offset (eq? blabel *start-label*))
+        block np)
+       (loop (cdr directives) dir-stack
+             (+ pc block-offset-width)
+             pc-stack np
+             last-blabel blabel)))
 
     (define (evaluation handler expression l)
       (actual-bits (handler
@@ -159,18 +170,21 @@ MIT in each case. |#
           (let ((this (car directives)))
             (case (vector-ref this 0)
               ((LABEL)
-               (loop (cdr directives) dir-stack pc pc-stack position))
+               (loop (cdr directives) dir-stack pc pc-stack position
+                     last-blabel blabel))
               ((TICK)
                (loop (cdr directives) dir-stack
                      pc
                      (if (vector-ref this 1)
                          (cons (->machine-pc pc) pc-stack)
                          (cdr pc-stack))
-                     position))
+                     position
+                     last-blabel blabel))
               ((FIXED-WIDTH-GROUP)
                (loop (vector-ref this 2) (cons (cdr directives) dir-stack)
                      pc pc-stack
-                     position))
+                     position
+                     last-blabel blabel))
               ((CONSTANT)
                (let ((bs (vector-ref this 1)))
                  (actual-bits bs (bit-string-length bs))))
@@ -183,15 +197,24 @@ MIT in each case. |#
                  (evaluation (variable-handler-wrapper (selector/handler sel))
                              (vector-ref this 1)
                              (selector/length sel))))
+              ((BLOCK-OFFSET)
+               (let* ((label (vector-ref this 1))
+                      (offset (evaluate `(- ,label ,blabel) '())))
+                 (if (> offset maximum-block-offset)
+                     (block-offset (evaluate `(- ,label ,last-blabel) '())
+                                   label last-blabel)
+                     (block-offset offset label blabel))))
               (else
                (error "assemble-directives!: Unknown directive" this)))))
          ((not (null? dir-stack))
-          (loop (car dir-stack) (cdr dir-stack) pc pc-stack position))
+          (loop (car dir-stack) (cdr dir-stack) pc pc-stack position
+                last-blabel blabel))
          ((not (= (+ block-length starting-pc) (+ pc position)))
           (error "assemble-directives!: phase error"
                  block-length pc position))
          (else (assemble-objects! block))))
-  (loop directives '() starting-pc '() block-length))
+  (loop directives '() starting-pc '() block-length
+       *start-label* *start-label*))
 \f
 ;;;; Input conversion
 
@@ -262,6 +285,10 @@ MIT in each case. |#
                      (process-fixed-width (list->vector this)
                                           (bit-string-length (cadr this))))
 
+                    ((BLOCK-OFFSET)
+                     (process-fixed-width (list->vector this)
+                                          block-offset-width))
+
                     ((EVALUATION)
                      (process-fixed-width (list->vector this)
                                           (caddr this)))

diff --git a/v7/src/compiler/back/syerly.scm b/v7/src/compiler/back/syerly.scm
index c01ed2cfc33f64f59e71075aad85448cfae02487..15851b38499d0fe5daa0b112e875ebc29cf48c36 100644 (file)
--- a/v7/src/compiler/back/syerly.scm
+++ b/v7/src/compiler/back/syerly.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.2 1987/07/01 20:47:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.3 1987/07/30 21:27:11 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -62,7 +62,7 @@ MIT in each case. |#
             ((eq? (car instruction) 'UNQUOTE)
              (if-not-expanded))
             ((memq (car instruction)
-                   '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL))
+                   '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL BLOCK-OFFSET))
              (if-expanded
               (scode/make-combination
                (scode/make-variable  'DIRECTIVE->INSTRUCTION-SEQUENCE)

diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm
index 2584a38e1250ea1ad8fcae54f1d0ac289606a1c7..0b0b1f25e73df0701221ce6f367710d2d04d8fbc 100644 (file)
--- a/v7/src/compiler/back/syntax.scm
+++ b/v7/src/compiler/back/syntax.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.18 1987/07/30 07:05:33 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.19 1987/07/30 21:27:21 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -60,7 +60,8 @@ MIT in each case. |#
           directives1))))
 
 (define-export (lap:syntax-instruction instruction)
-  (if (memq (car instruction) '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL))
+  (if (memq (car instruction)
+           '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL BLOCK-OFFSET))
       (directive->instruction-sequence instruction)
       (let ((match-result (instruction-lookup instruction)))
        (or (and match-result