--- /dev/null
+#| -*-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))
+\f
+;;;; 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))
+\f
+;;;; 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)))
+\f
+(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))
+\f
+;;;; 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))
+\f
+ (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 '() '() '())))
+\f
+(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 '() '()))
+\f
+(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 '())))
--- /dev/null
+#| -*-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))
+\f
+;;;; 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*)))
+\f
+;;;; 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)))))
+\f
+;;;; 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))))
+\f
+;;;; 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))
+\f
+;;;; 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)))
projects / mit-scheme.git / commitdiff