From e10e86f8beb8cb84c55c3edd51f08d9440e4dbb9 Mon Sep 17 00:00:00 2001
From: "Guillermo J. Rozas" <edu/mit/csail/zurich/gjr>
Date: Wed, 15 Jul 1987 03:01:03 +0000
Subject: [PATCH] Initial revision

---
 v7/src/compiler/back/bittop.scm | 397 ++++++++++++++++++++++++++++++++
 v7/src/compiler/back/bitutl.scm | 263 +++++++++++++++++++++
 2 files changed, 660 insertions(+)
 create mode 100644 v7/src/compiler/back/bittop.scm
 create mode 100644 v7/src/compiler/back/bitutl.scm

diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm
new file mode 100644
index 000000000..4dfb212db
--- /dev/null
+++ b/v7/src/compiler/back/bittop.scm
@@ -0,0 +1,397 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.1 1987/07/15 03:01:03 jinx Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Assembler Top Level
+
+(declare (usual-integrations))
+
+(define *equates*)
+(define *objects*)
+(define *entry-points*)
+(define *linkage-info*)
+(define *the-symbol-table*)
+(define *start-label*)
+(define *end-label*)
+
+(define object-address-width
+  (quotient scheme-object-width addressing-granularity))
+
+;;; Vector header and NMV header for code section
+
+(define compiler-output-block-number-of-header-words 2)
+
+(define starting-pc
+  (* compiler-output-block-number-of-header-words scheme-object-width))
+
+;;;; Assembler top level procedure
+
+(define (assemble start-label input linker)
+  (with-values
+   (lambda ()
+     (fluid-let ((*equates* (make-queue))
+		 (*objects* (make-queue))
+		 (*entry-points* (make-queue))
+		 (*linkage-info* (make-queue))
+		 (*the-symbol-table* (make-symbol-table))
+		 (*start-label* start-label)
+		 (*end-label* (generate-uninterned-symbol 'END-LABEL-)))
+       (initialize-symbol-table!)
+       (with-values
+	(lambda ()
+	  (initial-phase (instruction-sequence->directives input)))
+	(lambda (directives vars)
+	  (relax! directives vars)
+	  (let ((code-block (final-phase directives)))
+	    (values code-block
+		    (queue->list *entry-points*)
+		    (symbol-table->assq-list *the-symbol-table*)
+		    (queue->list *linkage-info*)))))))
+   linker))
+
+(define (relax! directives vars)
+  (define (tension-message count)
+    (newline)
+    (display "assemble: Branch tensioning done in ")
+    (write (1+ count))
+    (if (zero? count)
+	(display " iteration.")
+	(display " iterations.")))
+
+  (define (loop vars count)
+    (finish-symbol-table!)
+    (if (null? vars)
+	(tension-message count)
+	(with-values (lambda () (phase-2 vars))
+	 (lambda (any-modified? number-of-vars)
+	   (if any-modified?
+	       (begin
+		 (clear-symbol-table!)
+		 (initialize-symbol-table!)
+		 (loop (phase-1 directives) (1+ count)))
+	       (tension-message count))))))
+  (loop vars 0))
+
+;;;; Output block generation
+
+(define (bit-string-insert! b1 b2 position)
+  (bit-substring-move-right! b1 0 (bit-string-length b1) b2 position))
+
+(define (final-phase directives)
+  ;; Label values are now integers.
+  (for-each (lambda (pair)
+	      (let ((val (binding-value (cdr pair))))
+		(if (interval? val)
+		    (set-binding-value! (cdr pair) (interval-low val)))))
+	    (symbol-table-bindings *the-symbol-table*))
+  (let ((start (symbol-table-value *the-symbol-table* *start-label*))
+	(end (symbol-table-value *the-symbol-table* *end-label*)))
+    (let ((length (- (* addressing-granularity end) starting-pc)))
+      (let ((output-block
+	     (bit-string-allocate (+ scheme-object-width length))))
+	(bit-string-insert!
+	 (make-nmv-header (quotient (- end start) object-address-width))
+	 output-block
+	 length)
+	(assemble-directives! output-block directives length)))))
+
+(define (assemble-objects! block)
+  (let ((objects (queue->list *objects*))
+	(bl (/ (bit-string-length block) scheme-object-width)))
+    (let* ((ol (length objects))
+	   (v (make-vector (+ ol bl))))
+      (write-bits! v scheme-object-width block)
+      (insert-objects! (primitive-set-type (ucode-type compiled-code-block) v)
+		       objects bl))))
+
+(define (insert-objects! v objects where)
+  (cond ((not (null? objects))
+	 (system-vector-set! v where (cadar objects))
+	 (insert-objects! v (cdr objects) (1+ where)))
+	((not (= where (system-vector-size v)))
+	 (error "insert-objects!: object phase error" where))
+	(else v)))
+
+(define (assemble-directives! block directives block-length)
+
+  (define (loop directives dir-stack pc pc-stack position)
+
+    (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)))
+
+    (define (evaluation handler expression l)
+      (actual-bits (handler
+		    (evaluate expression
+			      (if (null? pc-stack)
+				  (->machine-pc pc)
+				  (car pc-stack))))
+		   l))
+
+    (cond ((not (null? directives))
+	   (let ((this (car directives)))
+	     (case (vector-ref this 0)
+	       ((LABEL)
+		(loop (cdr directives) dir-stack pc pc-stack position))
+	       ((TICK)
+		(loop (cdr directives) dir-stack
+		      pc
+		      (if (vector-ref this 1)
+			  (cons (->machine-pc pc) pc-stack)
+			  (cdr pc-stack))
+		      position))
+	       ((FIXED-WIDTH-GROUP)
+		(loop (vector-ref this 2) (cons (cdr directives) dir-stack)
+		      pc pc-stack
+		      position))
+	       ((CONSTANT)
+		(let ((bs (vector-ref this 1)))
+		  (actual-bits bs (bit-string-length bs))))
+	       ((EVALUATION)
+		(evaluation (vector-ref this 3)
+			    (vector-ref this 1)
+			    (vector-ref this 2)))
+	       ((VARIABLE-WIDTH-EXPRESSION)
+		(let ((sel (vector-ref this 3)))
+		  (evaluation (selector/handler sel)
+			      (vector-ref this 1)
+			      (selector/length sel))))
+	       (else
+		(error "assemble-directives!: Unknown directive" this)))))
+	  ((not (null? dir-stack))
+	   (loop (car dir-stack) (cdr dir-stack) pc pc-stack position))
+	  ((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))
+
+;;;; Input conversion
+
+(define (initial-phase input)
+  (let ((directives (make-queue)))
+    (define (loop to-convert pcmin pcmax pc-stack group vars)
+      (define (collect-group!)
+	(if (not (null? group))
+	    (add-to-queue! directives
+			   (vector 'FIXED-WIDTH-GROUP
+				   (car group)
+				   (reverse! (cdr group))))))
+
+      (define (new-directive! dir)
+	(collect-group!)
+	(add-to-queue! directives dir))
+
+      (define (process-label! label)
+	(symbol-table-define! *the-symbol-table*
+			      (cadr label)
+			      (make-machine-interval pcmin pcmax))
+	(new-directive! (list->vector label)))
+
+      (define (process-fixed-width directive width)
+	(loop (cdr to-convert)
+	      (+ width pcmin) (+ width pcmax) pc-stack
+	      (if (null? group)
+		  (cons width (list directive))
+		  (cons (+ width (car group))
+			(cons directive (cdr group))))
+	      vars))
+
+      (define (process-variable-width directive)
+	(new-directive! directive)
+	(variable-width-lengths directive
+	 (lambda (minl maxl)
+	   (loop (cdr to-convert)
+		 (+ pcmin minl) (+ pcmax maxl)
+		 pc-stack '()
+		 (cons directive vars)))))
+
+      (define (process-trivial-directive)
+	(loop (cdr to-convert)
+	      pcmin pcmax pc-stack
+	      group vars))
+
+      (if (null? to-convert)
+	  (let ((emin (pad pcmin))
+		(emax (+ pcmax maximum-padding-length)))
+	    (symbol-table-define! *the-symbol-table*
+				  *end-label*
+				  (make-machine-interval emin emax))
+	    (collect-group!)
+	    (values (queue->list directives) vars))
+	  (let ((this (car to-convert)))
+	    (cond ((bit-string? this)
+		   (process-fixed-width (vector 'CONSTANT this)
+					(bit-string-length this)))
+		  ((not (pair? this))
+		   (error "initial-phase: Unknown directive" this))
+		  (else
+		   (case (car this)
+		     ((LABEL)
+		      (process-label! this)
+		      (loop (cdr to-convert) pcmin pcmax pc-stack '() vars))
+
+		     ((CONSTANT)
+		      (process-fixed-width (list->vector this)
+					   (bit-string-length (cadr this))))
+
+		     ((EVALUATION)
+		      (process-fixed-width (list->vector this)
+					   (caddr this)))
+
+		     ((VARIABLE-WIDTH-EXPRESSION)
+		      (process-variable-width
+		       (vector 'VARIABLE-WIDTH-EXPRESSION
+			       (cadr directive)
+			       (if (null? pc-stack)
+				   (make-machine-interval pcmin pcmax)
+				   (car pc-stack))
+			       (map list->vector (cddr directive)))))
+		     ((GROUP)
+		      (new-directive! (vector 'TICK true))
+		      (loop (append (cdr this)
+				    (cons '(TICK-OFF) (cdr to-convert)))
+			    pcmin pcmax
+			    (cons (make-machine-interval pcmin pcmax) pc-stack)
+			    '() vars))
+		     ((TICK-OFF)
+		      (new-directive! (vector 'TICK false))
+		      (loop (cdr to-convert) pcmin pcmax
+			    (cdr pc-stack) '() vars))
+		     ((EQUATE)
+		      (add-to-queue! *equates* (cdr this))
+		      (process-trivial-directive))
+		     ((SCHEME-OBJECT)
+		      (add-to-queue! *objects* (cdr this))
+		      (process-trivial-directive))
+		     ((ENTRY-POINT)
+		      (add-to-queue! *entry-points* (cadr this))
+		      (process-trivial-directive))
+		     ((LINKAGE-INFORMATION)
+		      (add-to-queue! *linkage-info* (cdr this))
+		      (process-trivial-directive))
+		     (else
+		      (error "initial-phase: Unknown directive" this))))))))
+    (loop input starting-pc starting-pc '() '() '())))
+
+(define (phase-1 directives)
+  (define (loop rem pcmin pcmax pc-stack vars)
+    (if (null? rem)
+	(let ((ecmin (pad pcmin))
+	      (emax (+ pcmax maximum-padding-length)))
+	  (symbol-table-define! *the-symbol-table*
+				*end-label*
+				(make-machine-interval emin emax))
+	  vars)
+	(let ((this (car rem)))
+	  (case (vector-ref this 0)
+	    ((LABEL)
+	     (symbol-table-define! *the-symbol-table*
+				   (vector-ref this 1)
+				   (make-machine-interval pcmin pcmax))
+	     (loop (cdr rem) pcmin pcmax pc-stack vars))
+	    ((FIXED-WIDTH-GROUP)
+	     (let ((l (vector-ref this 1)))
+	       (loop (cdr rem)
+		     (+ pcmin l)
+		     (+ pcmax l)
+		     pc-stack
+		     vars)))
+	    ((VARIABLE-WIDTH-EXPRESSION)
+	     (vector-set! this 2
+			  (if (null? pc-stack)
+			      (make-machine-interval pcmin pcmax)
+			      (car pc-stack)))
+	     (variable-width-lengths this
+	      (lambda (minl maxl)
+		(loop (cdr rem)
+		      (+ pcmin minl) (+ pcmax maxl)
+		      pc-stack
+		      (cons this vars)))))
+	    ((TICK)
+	     (loop (cdr rem)
+		   pcmin pcmax
+		   (if (vector-ref this 1)
+		       (cons (make-machine-interval pcmin pcmax) pc-stack)
+		       (cdr pc-stack))
+		   vars))
+	    (else
+	     (error "phase-1: Unknown directive" this))))))
+  (loop directives starting-pc starting-pc '() '()))
+
+(define (phase-2 vars)
+  (define (loop vars modified? count)
+    (if (null? vars)
+	(values modified? count)
+	(let ((var (car vars)))
+	  (let ((interval (->interval
+			   (evaluate (vector-ref var 1)
+				     (vector-ref var 2)))))
+	    (with-values
+	     (lambda ()
+	       (process-variable var
+				 (interval-low interval)
+				 (interval-high interval)))
+	     (lambda (determined? filtered?)
+	       (loop (cdr vars)
+		     (or modified? filtered?)
+		     (if determined? count (1+ count)))))))))
+  (loop vars false 0))
+
+(define (process-variable var minval maxval)
+  (define (loop sels dropped-some?)
+    (cond ((null? sels)
+	   (error "variable-width-expression: minimum value is too large"
+		  var minval))
+	  ((not (selector/fits? minval (car sels)))
+	   (loop (cdr sels) true))
+	  ((selector/fits? maxval (car sels))
+	   (variable-width->fixed! var (car sels))
+	   (values true dropped-some?))
+	  (dropped-some?
+	   (vector-set! var 3 sels)
+	   (values false true))
+	  (else (values false false))))
+  (loop (vector-ref var 3) false))
+
+(define (variable-width->fixed! var sel)
+  (let* ((l (selector/length sel))
+	 (v (vector 'EVALUATION
+		    (vector-ref var 1)	; Expression
+		    (selector/length sel)
+		    (selector/handler sel))))
+    (vector-set! var 0 'FIXED-WIDTH-GROUP)
+    (vector-set! var 1 l)
+    (vector-set! var 2 (list v))
+    (vector-set! var 3 '())))
diff --git a/v7/src/compiler/back/bitutl.scm b/v7/src/compiler/back/bitutl.scm
new file mode 100644
index 000000000..8807e07b3
--- /dev/null
+++ b/v7/src/compiler/back/bitutl.scm
@@ -0,0 +1,263 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bitutl.scm,v 1.1 1987/07/15 03:00:44 jinx Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Assembler utilities
+
+(declare (usual-integrations))
+
+;;;; Extra symbol table operations
+
+(define (clear-symbol-table!)
+  (set! *the-symbol-table* (make-symbol-table)))
+
+(define (initialize-symbol-table!)
+  (symbol-table-define! *the-symbol-table* *start-label* 0))
+
+(define (finish-symbol-table!)
+  (define (process-objects obj pcmin pcmax)
+    (if (null? obj)
+	'DONE
+	(begin
+	  (symbol-table-define! *the-symbol-table*
+				(caar obj)
+				(make-machine-interval pcmin pcmax))
+	  (process-objects (cdr obj)
+			   (+ pcmin scheme-object-width)
+			   (+ pcmax scheme-object-width)))))
+
+  ;; Handle scheme objects
+  (let ((val (symbol-table-value *the-symbol-table* *end-label*)))
+    (process-objects (queue->list *objects*)
+		     (* addressing-granularity (interval-low val))
+		     (* addressing-granularity (interval-high val))))
+
+  ;; Handle equates
+  (for-each (lambda (equate)
+	      (symbol-table-define!
+	       *the-symbol-table*
+	       (car equate)
+	       (evaluate (cadr equate) false)))
+	    (queue->list *equates*)))
+
+;;;; Expression evaluation and intervals
+
+(define (evaluate expression pc-value)
+  (define (inner exp)
+    (cond ((pair? exp)
+	   ((find-operator (car exp))
+	    (inner (cadr exp))
+	    (inner (caddr exp))))
+	  ((number? exp) exp)
+	  ((not (symbol? exp))
+	   (error "evaluate: bad expression" exp))
+	  ((eq? exp '*PC*) pc-value)
+	  (else
+	   (symbol-table-value *the-symbol-table* exp))))
+  (inner expression))
+
+(declare (integrate-operator ->machine-pc make-machine-interval
+			     make-interval interval?
+			     interval-low interval-high))
+
+(define (->machine-pc pc)
+  (declare (integrate pc))
+  (paranoid-quotient pc addressing-granularity))
+
+;; Machine intervals are always in addressing units.
+
+(define (make-machine-interval low high)
+  (declare (integrate low high))
+  (make-interval (->machine-pc low)
+		 (->machine-pc high)))
+
+(define (->interval value)
+  (if (interval? value)
+      value
+      (make-interval value value)))
+
+(define (make-interval low high)
+  (declare (integrate low high))
+  (vector 'INTERVAL low high))
+
+(define (interval? obj)
+  (declare (integrate obj))
+  (and (vector? obj)
+       (eq? (vector-ref obj 0) 'INTERVAL)))
+
+(define (interval-low obj)
+  (declare (integrate obj))
+  (vector-ref obj 1))
+
+(define (interval-high obj)
+  (declare (integrate obj))
+  (vector-ref obj 2))
+
+(define (paranoid-quotient dividend divisor)
+  (let ((result (integer-divide dividend divisor)))
+    (if (zero? (integer-divide-remainder result))
+	(integer-divide-quotient result)
+	(error "paranoid-quotient: not a multiple" dividend divisor))))
+
+(define (pad pcvalue)
+  (let ((r (remainder pcvalue scheme-object-width)))
+    (if (zero? r)
+	pcvalue
+	(+ pcvalue (- scheme-object-width r)))))
+
+;;;; Operators
+
+(define operators '())
+
+(define (define-operator! keyword procedure)
+  (set! operators `((,keyword . ,procedure) ,@operators)))
+
+(define (find-operator keyword)
+  (let ((place (assq keyword operators)))
+    (if (null? place)
+	(error "evaluate: unknown operator" keyword)
+	(cdr place))))
+
+(define ((symmetric scalar) op1 op2)
+  (if (interval? op1)
+      (if (interval? op2)
+	  (make-interval (scalar (interval-low op1) (interval-low op2))
+			 (scalar (interval-high op1) (interval-high op2)))
+	  (make-interval (scalar (interval-low op1) op2)
+			 (scalar (interval-high op1) op2)))
+      (if (interval? op2)
+	  (make-interval (scalar op1 (interval-low op2))
+			 (scalar op1 (interval-high op2)))
+	  (scalar op1 op2))))
+
+(define-operator! '+ (symmetric +))
+(define-operator! '- (symmetric -))
+
+;; Only one argument can be an interval.
+
+(define-operator! '*
+  (lambda (op1 op2)
+    (cond ((interval? op1)
+	   (make-interval (* (interval-low op1) op2)
+			  (* (interval-high op1) op2)))
+	  ((interval? op2)
+	   (make-interval (* op1 (interval-low op2))
+			  (* op1 (interval-high op2))))
+	  (else (* op1 op2)))))
+
+;; Only the first argument can be an interval
+
+(define-operator! '/
+  (lambda (op1 op2)
+    (if (interval? op1)
+	(make-interval (paranoid-quotient (interval-low op1) op2)
+		       (paranoid-quotient (interval-high op1) op2))
+	(paranoid-quotient op1 op2))))
+
+;;;; Variable width expression utilities
+
+(define (variable-width-lengths v receiver)
+  (define (loop selectors min max)
+    (cond ((null? selectors)
+	   (receiver min max))
+	  ((< (selector/length (car selectors)) min)
+	   (loop (cdr selectors)
+		 (selector/length (car selectors))
+		 max))
+	  ((> (selector/length (car selectors)) max)
+	   (loop (cdr selectors)
+		 min
+		 (selector/length (car selectors))))
+	  (else
+	   (loop (cdr selectors) min max))))
+  (let ((sel (vector-ref v 3)))
+    (if (null? sel)
+	(error "variable-width-lengths: Bad variable width directive" v)
+	(loop (cdr sel)
+	      (selector/length (car sel))
+	      (selector/length (car sel))))))
+
+(define (selector/fits? val sel)
+  (let ((low (selector/low sel))
+	(high (selector/high sel)))
+    (and (or (false? low) (<= low val))
+	 (or (false? high) (<= val high)))))
+
+(declare (integrate-operator selector/low selector/high
+			     selector/handler selector/length))
+
+(define (selector/low sel)
+  (declare (integrate sel))
+  (vector-ref sel 0))
+
+(define (selector/high sel)
+  (declare (integrate sel))
+  (vector-ref sel 1))
+
+(define (selector/handler sel)
+  (declare (integrate sel))
+  (vector-ref sel 2))
+
+(define (selector/length sel)
+  (declare (integrate sel))
+  (vector-ref sel 3))
+
+;;;; Random utilities
+
+;;; Queues
+
+(declare (integrate-operator make-queue queue->list))
+
+(define (make-queue)
+  (cons '() '()))
+
+(define (queue->list queue)
+  (declare (integrate queue))
+  (car queue))
+
+(define (add-to-queue! queue entry)
+  (let ((new (cons entry '())))
+    (if (null? (cdr queue))
+	(set-car! queue new)
+	(set-cdr! (cdr queue) new))
+    (set-cdr! queue new)))
+
+;;; Multiple values
+
+(declare (integrate-operator values with-values))
+
+(define values list)
+
+(define (with-values thunk receiver)
+  (declare (integrate thunk receiver))
+  (apply receiver (thunk)))
-- 
2.25.1