From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Thu, 30 Jul 1987 21:27:21 +0000 (+0000)
Subject: Reimplement 32 bit offsets in compiled code blocks.  They are now
X-Git-Tag: 20090517-FFI~13201
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=02a5cd36abb4fcf3d5e51b54ab8319152ca9397f;p=mit-scheme.git

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 245bfcce1..66be6b037 100644
--- 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. |#
 
 (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*))
 
 ;;;; 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 c01ed2cfc..15851b384 100644
--- 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 2584a38e1..0b0b1f25e 100644
--- 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