--- /dev/null
+#| -*-Scheme-*-
+
+$Id: asmmac.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1988, 1990 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 Syntax Macros
+
+(declare (usual-integrations))
+\f
+(syntax-table-define assembler-syntax-table 'DEFINE-INSTRUCTION
+ (macro (keyword . rules)
+ `(ADD-INSTRUCTION!
+ ',keyword
+ ,(compile-database rules
+ (lambda (pattern actions)
+ pattern
+ (if (null? actions)
+ (error "DEFINE-INSTRUCTION: Too few forms")
+ (parse-instruction (car actions) (cdr actions) false)))))))
+
+#|
+;; Old version form interpretive pattern matcher:
+(define (compile-database cases procedure)
+ `(LIST
+ ,@(map (lambda (rule)
+ (parse-rule (car rule) (cdr rule)
+ (lambda (pattern variables qualifier actions)
+ `(CONS ',pattern
+ ,(rule-result-expression variables
+ qualifier
+ (procedure pattern
+ actions))))))
+ cases)))
+|#
+
+(define (compile-database cases procedure)
+ `(LIST
+ ,@(map (lambda (rule)
+ (parse-rule (car rule) (cdr rule)
+ (lambda (pattern variables qualifier actions)
+ `(CONS ',pattern
+ ,(compile-pattern pattern
+ (rule-result-expression
+ variables qualifier
+ (procedure pattern actions)))))))
+ cases)))
+
+
+(define optimize-group-syntax
+ (let ()
+ (define (find-constant components)
+ (cond ((null? components)
+ '())
+ ((car-constant? components)
+ (compact (car-constant-value components)
+ (cdr components)))
+ (else
+ (cons (car components)
+ (find-constant (cdr components))))))
+
+ (define (compact bit-string components)
+ (cond ((null? components)
+ (cons (make-constant bit-string) '()))
+ ((car-constant? components)
+ (compact (instruction-append bit-string
+ (car-constant-value components))
+ (cdr components)))
+ (else
+ (cons (make-constant bit-string)
+ (cons (car components)
+ (find-constant (cdr components)))))))
+
+ (define-integrable (car-constant? expression)
+ (and (eq? (caar expression) 'QUOTE)
+ (bit-string? (cadar expression))))
+
+ (define-integrable (car-constant-value constant)
+ (cadar constant))
+
+ (define-integrable (make-constant bit-string)
+ `',bit-string)
+
+ (lambda (components early?)
+ (let ((components (find-constant components)))
+ (cond ((null? components)
+ (error "OPTIMIZE-GROUP-SYNTAX: No components in group!"))
+ ((null? (cdr components))
+ (car components))
+ (else
+ `(,(if early?
+ 'OPTIMIZE-GROUP-EARLY
+ 'OPTIMIZE-GROUP)
+ ,@components)))))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: asutl.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1992 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
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+(define-integrable (back-end:= x y)
+ (= x y))
+
+(define-integrable (back-end:+ x y)
+ (+ x y))
+
+(define-integrable (back-end:- x y)
+ (- x y))
+
+(define-integrable (back-end:* x y)
+ (* x y))
+
+(define-integrable (back-end:quotient x y)
+ (quotient x y))
+
+(define-integrable (back-end:expt x y)
+ (expt x y))
+
+(define-integrable (back-end:< x y)
+ (< x y))
+
+(define make-non-pointer-literal
+ (let ((type-maximum (expt 2 scheme-type-width))
+ (type-scale-factor (expt 2 scheme-datum-width)))
+ (lambda (type datum)
+ (if (not (and (exact-nonnegative-integer? type)
+ (< type type-maximum)))
+ (error "non-pointer type out of range" type))
+ (if (not (and (exact-nonnegative-integer? datum)
+ (< datum type-scale-factor)))
+ (error "non-pointer datum out of range" datum))
+ (+ (* type type-scale-factor) datum))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: bittop.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1988-1993 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
+;;; package: (compiler assembler)
+
+(declare (usual-integrations))
+\f
+(define *equates*)
+(define *objects*)
+(define *entry-points*)
+(define *the-symbol-table*)
+(define *start-label*)
+(define *end-label*)
+
+;;;; Assembler top level procedure
+
+(define (assemble start-label instructions)
+ (fluid-let ((*equates* (make-queue))
+ (*objects* (make-queue))
+ (*entry-points* (make-queue))
+ (*the-symbol-table* (make-symbol-table))
+ (*start-label* start-label)
+ (*end-label* (generate-uninterned-symbol 'END-LABEL-)))
+ (initialize-symbol-table!)
+ (call-with-values
+ (lambda ()
+ (initial-phase
+ (if (null? instructions)
+ '()
+ (let ((holder (list 'HOLDER)))
+ (let loop ((tail holder)
+ (instructions
+ (let ((i instructions))
+ (set! instructions)
+ i)))
+ (if (not (null? instructions))
+ (let ((first (car instructions)))
+ (if (and (pair? first)
+ (eq? (car first) 'COMMENT))
+ (loop tail (cdr instructions))
+ (begin
+ (set-cdr! tail
+ (lap:syntax-instruction first))
+ (loop (last-pair tail) (cdr instructions)))))))
+ (cdr holder)))))
+ (lambda (directives vars)
+ (let* ((count (relax! directives vars))
+ (block (assemble-objects (final-phase directives))))
+ (values count
+ block
+ (queue->list *entry-points*)
+ (symbol-table->assq-list *the-symbol-table*)))))))
+
+(define (relax! directives vars)
+ (define (continue widening? count)
+ (clear-symbol-table!)
+ (initialize-symbol-table!)
+ (loop widening?
+ (phase-1 widening? directives)
+ (1+ count)))
+
+ (define (loop widening? vars count)
+ (finish-symbol-table!)
+ (if (null? vars)
+ count
+ (call-with-values (lambda () (phase-2 widening? vars))
+ (lambda (any-modified? number-of-vars)
+ (cond (any-modified?
+ (continue false count))
+ ((zero? number-of-vars)
+ count)
+ (else
+ (continue (not widening?) count)))))))
+ (loop false vars 0))
+\f
+;;; 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))
+
+;;;; Output block generation
+
+(define (final-phase directives)
+ ;; Convert label values to integers:
+ (for-each (lambda (pair)
+ (set-binding-value!
+ (cdr pair)
+ (interval-final-value (binding-value (cdr pair)))))
+ (symbol-table-bindings *the-symbol-table*))
+ (let ((code-block
+ (bit-string-allocate (- (->bitstring-pc
+ (symbol-table-value *the-symbol-table*
+ *end-label*))
+ starting-pc))))
+ (assemble-directives! code-block
+ directives
+ (instruction-initial-position code-block))
+ code-block))
+\f
+(define (assemble-objects code-block)
+ (let ((objects (map assemble-an-object (queue->list *objects*))))
+ (if compiler:cross-compiling?
+ (vector 'DEBUGGING-INFO-SLOT code-block objects scheme-object-width)
+ (let* ((bl (quotient (bit-string-length code-block)
+ scheme-object-width))
+ (non-pointer-length
+ ((ucode-primitive make-non-pointer-object) bl))
+ (objects-length (length objects))
+ (total-length (fix:+ 1 (fix:+ objects-length bl)))
+ (flo-length
+ (let ((flo-size (fix:quotient float-width scheme-datum-width)))
+ (fix:quotient (fix:+ total-length (fix:- flo-size 1))
+ flo-size)))
+ (output-block
+ (object-new-type (ucode-type compiled-code-block)
+ (flo:vector-cons flo-length))))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let ((ob (object-new-type (ucode-type vector) output-block)))
+ (subvector-fill! ob
+ (fix:+ bl 1)
+ (system-vector-length ob)
+ #f)
+ (vector-set! ob 0
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type manifest-nm-vector)
+ non-pointer-length)))))
+ (write-bits! output-block
+ ;; After header just inserted.
+ (* scheme-object-width 2)
+ code-block)
+ ((ucode-primitive primitive-object-set! 3)
+ output-block 0
+ ;;(object-new-type (ucode-type null) total-length)
+ (object-new-type (ucode-type manifest-vector) total-length))
+ (insert-objects! output-block objects (fix:+ bl 1))
+ output-block))))
+
+(define (assemble-an-object object)
+ (case (car object)
+ ((SCHEME-OBJECT)
+ ;; (SCHEME-OBJECT <deflabel> <object>)
+ (cdr object))
+ ((SCHEME-EVALUATION)
+ ;; (SCHEME-EVALUATION <deflabel> <offlabel>)
+ (list (cadr object) (evaluate (caddr object) false)))
+ (else
+ (error "assemble-an-object: Unknown kind"
+ object))))
+
+(define (insert-objects! v objects where)
+ (cond ((not (null? objects))
+ (system-vector-set! v where (cadar objects))
+ (insert-objects! v (cdr objects) (fix:+ where 1)))
+ ((not (fix:= where (system-vector-length v)))
+ (error "insert-objects!: object phase error" where))
+ (else unspecific)))
+\f
+(define (assemble-directives! block directives initial-position)
+
+ (define (loop directives dir-stack pc pc-stack position last-blabel blabel)
+
+ (define (actual-bits bits l)
+ (instruction-insert! bits block position
+ (lambda (np)
+ (declare (integrate np))
+ (loop (cdr directives) dir-stack (+ pc l) pc-stack np
+ last-blabel blabel))))
+
+ (define (block-offset offset last-blabel blabel)
+ (instruction-insert!
+ (block-offset->bit-string offset (eq? blabel *start-label*))
+ block position
+ (lambda (np)
+ (declare (integrate np))
+ (loop (cdr directives) dir-stack
+ (+ pc block-offset-width)
+ pc-stack np
+ last-blabel blabel))))
+
+ (define (evaluation handler expression l)
+ (actual-bits (handler
+ (evaluate expression
+ (if (null? pc-stack)
+ (->machine-pc pc)
+ (car pc-stack))))
+ l))
+
+ (define (end-assembly)
+ (cond ((not (null? dir-stack))
+ (loop (car dir-stack) (cdr dir-stack) pc pc-stack position
+ last-blabel blabel))
+ ((not (= (abs (- position initial-position))
+ (- pc starting-pc)))
+ (error "assemble-directives!: phase error"
+ `(PC ,starting-pc ,pc)
+ `(BIT-POSITION ,initial-position ,position)))
+ ((not (= (symbol-table-value *the-symbol-table* *end-label*)
+ (->machine-pc (final-pad pc))))
+ (error "assemble-directives!: phase error"
+ `(LABEL ,*end-label*)
+ `(ACTUAL-PC ,(->machine-pc (final-pad pc)))
+ `(RESOLVED-PC ,(symbol-table-value
+ *the-symbol-table*
+ *end-label*))))
+ (else
+ (final-pad! block pc position))))
+\f
+ (if (null? directives)
+ (end-assembly)
+ (let ((this (car directives)))
+ (case (vector-ref this 0)
+ ((LABEL)
+ (let* ((label (vector-ref this 1))
+ (pcdef (symbol-table-value *the-symbol-table* label)))
+ (if (not (= pcdef (->machine-pc pc)))
+ (error "assemble-directives!: phase error"
+ `(LABEL ,label)
+ `(ACTUAL-PC ,pc)
+ `(RESOLVED-PC ,pcdef))))
+ (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
+ last-blabel blabel))
+ ((FIXED-WIDTH-GROUP)
+ (loop (vector-ref this 2) (cons (cdr directives) dir-stack)
+ pc pc-stack
+ position
+ last-blabel blabel))
+ ((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 (car (vector-ref this 3))))
+ (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))))
+ ((PADDING)
+ (let ((remdr (vector-ref this 1))
+ (divsr (vector-ref this 2))
+ (padding-string (vector-ref this 3)))
+ (let* ((pc* (->bitstring-pc (paddify (->machine-pc pc)
+ remdr divsr)))
+ (pc-diff (- pc* pc))
+ (padding-length (bit-string-length padding-string)))
+ (if (not (zero? (remainder pc-diff padding-length)))
+ (error "assemble-directives!: Bad padding"
+ pc this)
+ (actual-bits (replicate padding-string
+ (quotient pc-diff padding-length))
+ pc-diff)))))
+ (else
+ (error "assemble-directives!: Unknown directive" this))))))
+
+ (loop directives '() starting-pc '() initial-position
+ *start-label* *start-label*))
+\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)
+ (set-label-value! (cadr label) 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)
+ (call-with-values (lambda () (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 (final-pad pcmin))
+ (emax (+ pcmax maximum-padding-length)))
+ (set-label-value! *end-label* emin emax)
+ (collect-group!)
+ (values (queue->list directives) vars))
+\f
+ (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)
+ ((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 this)
+ (if (null? pc-stack)
+ (label->machine-interval pcmin pcmax)
+ (car pc-stack))
+ (map list->vector (cddr this)))))
+ ((GROUP)
+ (new-directive! (vector 'TICK true))
+ (loop (append (cdr this)
+ (cons '(TICK-OFF) (cdr to-convert)))
+ pcmin pcmax
+ (cons (label->machine-interval pcmin pcmax)
+ pc-stack)
+ '() vars))
+ ((TICK-OFF)
+ (new-directive! (vector 'TICK false))
+ (loop (cdr to-convert) pcmin pcmax
+ (cdr pc-stack) '() vars))
+ ((LABEL)
+ (process-label! this)
+ (loop (cdr to-convert) pcmin pcmax pc-stack '() vars))
+ ((BLOCK-OFFSET)
+ (process-fixed-width (list->vector this)
+ block-offset-width))
+ ((EQUATE)
+ (add-to-queue! *equates* (cdr this))
+ (process-trivial-directive))
+ ((SCHEME-OBJECT SCHEME-EVALUATION)
+ (add-to-queue! *objects* this)
+ (process-trivial-directive))
+ ((ENTRY-POINT)
+ (add-to-queue! *entry-points* (cadr this))
+ (process-trivial-directive))
+ ((PADDING)
+ (let ((directive (->padding-directive this)))
+ (new-directive! directive)
+ (after-padding
+ directive pcmin pcmax
+ (lambda (pcmin pcmax)
+ (loop (cdr to-convert) pcmin pcmax
+ pc-stack '() vars)))))
+ (else
+ (error "initial-phase: Unknown directive" this))))))))
+ (loop input starting-pc starting-pc '() '() '())))
+\f
+(define (phase-1 widening? directives)
+ (define (loop rem pcmin pcmax pc-stack vars)
+ (if (null? rem)
+ (let* ((emin (final-pad pcmin))
+ (emax (if (not widening?)
+ (+ pcmax maximum-padding-length)
+ emin)))
+ (set-label-value! *end-label* emin emax)
+ vars)
+ (let ((this (car rem)))
+ (case (vector-ref this 0)
+ ((LABEL)
+ (set-label-value! (vector-ref this 1) 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)
+ (label->machine-interval pcmin pcmax)
+ (car pc-stack)))
+ (call-with-values (lambda () (variable-width-lengths this))
+ (lambda (minl maxl)
+ (loop (cdr rem)
+ (+ pcmin minl)
+ (+ pcmax (if widening? minl maxl))
+ pc-stack
+ (cons this vars)))))
+ ((TICK)
+ (loop (cdr rem)
+ pcmin pcmax
+ (if (vector-ref this 1)
+ (cons (label->machine-interval pcmin pcmax) pc-stack)
+ (cdr pc-stack))
+ vars))
+ ((PADDING)
+ (after-padding
+ this pcmin pcmax
+ (lambda (pcmin pcmax)
+ (loop (cdr rem) pcmin pcmax pc-stack vars))))
+ (else
+ (error "phase-1: Unknown directive" this))))))
+ (loop directives starting-pc starting-pc '() '()))
+\f
+(define (phase-2 widening? vars)
+ (let loop ((vars vars) (modified? #f) (count 0))
+ (if (null? vars)
+ (values modified? count)
+ (call-with-values
+ (lambda ()
+ (let ((var (car vars)))
+ (call-with-values
+ (lambda ()
+ (interval-values (evaluate (vector-ref var 1)
+ (vector-ref var 2))))
+ (lambda (low high)
+ (process-variable var widening? low high)))))
+ (lambda (determined? filtered?)
+ (loop (cdr vars)
+ (or modified? filtered?)
+ (if determined? count (+ count 1))))))))
+
+(define (process-variable var widening? minval maxval)
+ (let loop ((dropped-some? #f))
+ (let ((sels (vector-ref var 3)))
+ (if (null? sels)
+ (error "Variable-width field cannot be resolved:" var))
+ (let ((low (selector/low (car sels)))
+ (high (selector/high (car sels))))
+ (cond ((and (or (null? low) (<= low minval))
+ (or (null? high) (<= maxval high)))
+ (if (not widening?)
+ (variable-width->fixed! var (car sels)))
+ (values #t dropped-some?))
+ ((and (or (null? low) (<= low maxval))
+ (or (null? high) (<= minval high)))
+ (values #f dropped-some?))
+ (else
+ (vector-set! var 3 (cdr sels))
+ (loop #t)))))))
+
+(define (variable-width->fixed! var sel)
+ (let* ((l (selector/length sel))
+ (v (vector 'EVALUATION
+ (vector-ref var 1) ; Expression
+ (selector/length sel)
+ (variable-handler-wrapper (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 '())))
+\f
+(define (variable-handler-wrapper handler)
+ (lambda (value)
+ (let ((l (handler value)))
+ (if (null? l)
+ (bit-string-allocate 0)
+ (list->bit-string l)))))
+
+(define (list->bit-string l)
+ (if (null? (cdr l))
+ (car l)
+ (instruction-append (car l)
+ (list->bit-string (cdr l)))))
+
+(define (replicate bstring n-times)
+ (let* ((blength (bit-string-length bstring))
+ (result (make-bit-string (* n-times blength) false)))
+ (do ((offset 0 (+ offset blength))
+ (ctr 0 (1+ ctr)))
+ ((>= ctr n-times))
+ (bit-substring-move-right! bstring 0 blength result offset))
+ result))
+
+(define (final-pad! block pc position)
+ (instruction-insert!
+ (replicate padding-string
+ (quotient (- (final-pad pc) pc)
+ (bit-string-length padding-string)))
+ block
+ position
+ (lambda (new-position)
+ new-position ; ignored
+ unspecific)))
+
+(define (->padding-directive this)
+ (let ((remdr (cadr this))
+ (divsr (caddr this))
+ (bstring (if (null? (cdddr this))
+ padding-string
+ (cadddr this))))
+ (vector 'PADDING (modulo remdr divsr) divsr bstring)))
+
+(define-integrable (after-padding directive pcmin pcmax recvr)
+ (let ((remdr (vector-ref directive 1))
+ (divsr (vector-ref directive 2)))
+ (recvr (->bitstring-pc (paddify (->machine-pc pcmin) remdr divsr))
+ (->bitstring-pc (paddify (->machine-pc pcmax) remdr divsr)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: bitutl.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1987-1993 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
+;;; package: (compiler assembler)
+
+(declare (usual-integrations))
+\f
+(define-integrable (make-queue)
+ (cons '() '()))
+
+(define-integrable (queue->list 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)))
+
+(define-integrable (set-label-value! name low high)
+ (symbol-table-define! *the-symbol-table*
+ name
+ (label->machine-interval low high)))
+
+(define (clear-symbol-table!)
+ (set! *the-symbol-table* (make-symbol-table))
+ unspecific)
+
+(define (initialize-symbol-table!)
+ (symbol-table-define! *the-symbol-table* *start-label* 0))
+
+(define (finish-symbol-table!)
+ (call-with-values
+ (lambda ()
+ (interval-values (symbol-table-value *the-symbol-table* *end-label*)))
+ (lambda (low high)
+ (do ((objects (queue->list *objects*) (cdr objects))
+ (pcmin (->bitstring-pc low) (+ pcmin scheme-object-width))
+ (pcmax (->bitstring-pc high) (+ pcmax scheme-object-width)))
+ ((null? objects))
+ (set-label-value! (cadar objects) pcmin pcmax))))
+ (for-each (lambda (equate)
+ (symbol-table-define! *the-symbol-table*
+ (car equate)
+ (evaluate (cadr equate) #f)))
+ (queue->list *equates*)))
+
+(define (variable-width-lengths v)
+ (let ((sel (vector-ref v 3)))
+ (if (null? sel)
+ (error "Bad variable width directive:" v))
+ (let ((l (selector/length (car sel))))
+ (let loop ((selectors (cdr sel)) (min l) (max l))
+ (if (null? selectors)
+ (values min max)
+ (let ((this (selector/length (car selectors))))
+ (cond ((< this min) (loop (cdr selectors) this max))
+ ((> this max) (loop (cdr selectors) min this))
+ (else (loop (cdr selectors) min max)))))))))
+
+(define-integrable (selector/handler sel)
+ (vector-ref sel 0))
+
+(define-integrable (selector/length sel)
+ (vector-ref sel 1))
+
+(define-integrable (selector/low sel)
+ (vector-ref sel 2))
+
+(define-integrable (selector/high sel)
+ (vector-ref sel 3))
+\f
+;;;; Expression Evaluation
+
+(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*)
+ (if (not pc-value)
+ (error "evaluate: *PC* found with no PC defined"))
+ pc-value)
+ (else
+ (symbol-table-value *the-symbol-table* exp))))
+ (inner expression))
+
+(define (find-operator keyword)
+ (let ((place (assq keyword operators)))
+ (if (not place)
+ (error "evaluate: unknown operator:" keyword))
+ ((cdr place))))
+
+(define operators
+ `((+ . ,(lambda () interval:+))
+ (- . ,(lambda () interval:-))
+ (* . ,(lambda () interval:*))
+ (/ . ,(lambda () interval:/))
+ (QUOTIENT . ,(lambda () interval:quotient))
+ (REMAINDER . ,(lambda () interval:remainder))))
+
+(define-integrable (->machine-pc pc)
+ (paranoid-quotient pc addressing-granularity))
+
+(define-integrable (->bitstring-pc pc)
+ (* pc addressing-granularity))
+
+(define (paranoid-quotient dividend divisor)
+ (let ((result (integer-divide dividend divisor)))
+ (if (not (zero? (integer-divide-remainder result)))
+ (error "paranoid-quotient: not a multiple" dividend divisor))
+ (integer-divide-quotient result)))
+
+(define (final-pad pcvalue)
+ (paddify pcvalue 0 scheme-object-width))
+
+(define (paddify pc-val remdr divsr)
+ (let ((aremdr (remainder pc-val divsr)))
+ (+ pc-val
+ (if (<= aremdr remdr)
+ (- remdr aremdr)
+ (+ remdr (- divsr aremdr))))))
+\f
+;;;; Interval Arithmetic
+
+(define-structure (interval (constructor %make-interval))
+ (offset #f read-only #t)
+ (segset #f read-only #t))
+
+(define-integrable (label->machine-interval low high)
+ (make-interval 0
+ (list (make-segment (make-point (->machine-pc low)
+ (->machine-pc high))
+ 1))))
+
+(define (make-interval offset segset)
+ (if (null? segset)
+ offset
+ (%make-interval offset segset)))
+
+(define (interval-values interval)
+ (if (interval? interval)
+ (let loop
+ ((result-1 (interval-offset interval))
+ (result-2 (interval-offset interval))
+ (base-1 0)
+ (base-2 0)
+ (segset (interval-segset interval)))
+ (if (null? segset)
+ (if (<= result-1 result-2)
+ (values result-1 result-2)
+ (values result-2 result-1))
+ (let ((position-1 (segment-min (car segset)))
+ (position-2 (segment-max (car segset)))
+ (k (segment-coeff (car segset))))
+ (loop (+ result-1 (* (- position-1 base-1) k))
+ (+ result-2 (* (- position-2 base-2) k))
+ position-1
+ position-2
+ (cdr segset)))))
+ (values interval interval)))
+
+(define (interval-final-value interval)
+ (if (interval? interval)
+ (let loop
+ ((result (interval-offset interval))
+ (base 0)
+ (segset (interval-segset interval)))
+ (if (null? segset)
+ result
+ (let ((position (segment-min (car segset)))
+ (k (segment-coeff (car segset))))
+ (loop (+ result (* (- position base) k))
+ position
+ (cdr segset)))))
+ interval))
+\f
+(define (interval:+ a b)
+ (if (interval? a)
+ (if (interval? b)
+ (make-interval (+ (interval-offset a) (interval-offset b))
+ (segset:+ (interval-segset a) (interval-segset b)))
+ (make-interval (+ (interval-offset a) b) (interval-segset a)))
+ (if (interval? b)
+ (make-interval (+ a (interval-offset b)) (interval-segset b))
+ (+ a b))))
+
+(define (interval:- a b)
+ (if (interval? a)
+ (if (interval? b)
+ (make-interval (- (interval-offset a) (interval-offset b))
+ (segset:- (interval-segset a) (interval-segset b)))
+ (make-interval (- (interval-offset a) b) (interval-segset a)))
+ (if (interval? b)
+ (make-interval (- a (interval-offset b))
+ (segset:negate (interval-segset b)))
+ (- a b))))
+
+(define (interval:* a b)
+ (if (interval? a)
+ (if (interval? b)
+ (error "Can't multiply two intervals:" a b)
+ (make-interval (* (interval-offset a) b)
+ (segset:scale (interval-segset a) b)))
+ (if (interval? b)
+ (make-interval (* (interval-offset b) a)
+ (segset:scale (interval-segset b) a))
+ (* a b))))
+
+;;; Integer division on intervals is hard because the numerator of the
+;;; division is a summation. For exact division we can just check the
+;;; sum of the result to make sure it's an integer. QUOTIENT and
+;;; REMAINDER can't be done at all unless we constrain the remainder
+;;; of the high and low values to be the same.
+
+(define (interval:/ a b)
+ (if (interval? b)
+ (error "Can't divide by an interval:" b))
+ (if (interval? a)
+ (let ((result
+ (make-interval (/ (interval-offset a) b)
+ (segset:scale (interval-segset a) (/ 1 b)))))
+ (if (not
+ (call-with-values (lambda () (interval-values result))
+ (lambda (low high)
+ (and (integer? low)
+ (integer? high)))))
+ (error "Interval division not exact:" a b))
+ result)
+ (paranoid-quotient a b)))
+
+(define (interval:quotient a b)
+ (if (or (interval? a) (interval? b))
+ (error "QUOTIENT doesn't do intervals:" a b))
+ (quotient a b))
+
+(define (interval:remainder a b)
+ (if (or (interval? a) (interval? b))
+ (error "REMAINDER doesn't do intervals:" a b))
+ (remainder a b))
+\f
+;;; A segment consists of an ending point and a coefficient.
+;;; The ending point has a minimum and maximum non-negative integer value.
+;;; The coefficient is an integer.
+;;; min(s1)=min(s2) iff max(s1)=max(s2)
+;;; min(s1)<min(s2) iff max(s1)<max(s2)
+
+(define-integrable make-segment cons)
+(define-integrable segment-point car)
+(define-integrable segment-coeff cdr)
+
+(define-integrable make-point cons)
+(define-integrable point-min car)
+(define-integrable point-max cdr)
+
+(define-integrable (segment-min segment)
+ (point-min (segment-point segment)))
+
+(define-integrable (segment-max segment)
+ (point-max (segment-point segment)))
+
+(define-integrable (segment:< s1 s2)
+ (< (segment-min s1) (segment-min s2)))
+
+(define-integrable (segment:= s1 s2)
+ (= (segment-min s1) (segment-min s2)))
+
+;;; A segset is a list of segments.
+;;; The segments are sorted in order from least to greatest.
+;;; There is an implicit starting point of zero.
+
+(define (segset:+ a b)
+ (cond ((null? a) b)
+ ((null? b) a)
+ ((segment:< (car a) (car b))
+ (cons-segset (segment-point (car a))
+ (+ (segment-coeff (car a)) (segment-coeff (car b)))
+ (segset:+ (cdr a) b)))
+ (else
+ (cons-segset (segment-point (car b))
+ (+ (segment-coeff (car a)) (segment-coeff (car b)))
+ (segset:+ (if (segment:= (car a) (car b)) (cdr a) a)
+ (cdr b))))))
+
+(define (segset:- a b)
+ (cond ((null? a) (segset:negate b))
+ ((null? b) a)
+ ((segment:< (car a) (car b))
+ (cons-segset (segment-point (car a))
+ (- (segment-coeff (car a)) (segment-coeff (car b)))
+ (segset:- (cdr a) b)))
+ (else
+ (cons-segset (segment-point (car b))
+ (- (segment-coeff (car a)) (segment-coeff (car b)))
+ (segset:- (if (segment:= (car a) (car b)) (cdr a) a)
+ (cdr b))))))
+
+(define (segset:negate b)
+ (segset:scale b -1))
+
+(define (segset:scale b c)
+ (if (null? b)
+ b
+ (cons (make-segment (segment-point (car b))
+ (* (segment-coeff (car b)) c))
+ (segset:scale (cdr b) c))))
+
+(define (cons-segset point coeff segset)
+ (if (= coeff (if (null? segset) 0 (segment-coeff (car segset))))
+ segset
+ (cons (make-segment point coeff) segset)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/back/insseq.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1987, 1988, 1990 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. |#
+
+;;;; Lap instruction sequences
+
+(declare (usual-integrations))
+\f
+(define (instruction-sequence->directives instruction-sequence)
+ (if (null? instruction-sequence)
+ '()
+ (car instruction-sequence)))
+
+(define empty-instruction-sequence
+ '())
+
+(define (directive->instruction-sequence directive)
+ (let ((pair (cons directive '())))
+ (cons pair pair)))
+
+(define (instruction->instruction-sequence directives)
+ ;; This procedure is expanded in the syntaxer. See "syerly".
+ (cons directives (last-pair directives)))
+
+(define (copy-instruction-sequence instruction-sequence)
+ (if (null? instruction-sequence)
+ '()
+ (let with-last-pair ((l (car instruction-sequence)) (receiver cons))
+ (if (null? (cdr l))
+ (receiver l l)
+ (with-last-pair (cdr l)
+ (lambda (rest last)
+ (receiver (cons (car l) rest) last)))))))
+
+(define (append-instruction-sequences! x y)
+ (cond ((null? x) y)
+ ((null? y) x)
+ (else
+ (set-cdr! (cdr x) (car y))
+ (set-cdr! x (cdr y))
+ x)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: lapgn1.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; LAP Generator: top level
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define *current-bblock*)
+(define *pending-bblocks*)
+(define *insert-rtl?*)
+
+(define (generate-lap rgraphs remote-links process-constants-block)
+ (fluid-let ((*insert-rtl?*
+ (and compiler:generate-lap-files?
+ compiler:intersperse-rtl-in-lap?)))
+ (with-new-node-marks
+ (lambda ()
+ (for-each cgen-rgraph rgraphs)
+ (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* '()))
+ (for-each (lambda (edge)
+ (if (not (node-marked? (edge-right-node edge)))
+ (cgen-entry rgraph edge)))
+ (rgraph-entry-edges rgraph))
+ (if (not (null? *pending-bblocks*))
+ (error "CGEN-RGRAPH: pending blocks left at end of pass"))))
+
+(define (cgen-entry rgraph edge)
+ (define (loop bblock map)
+ (cgen-bblock bblock map)
+ (if (sblock? bblock)
+ (cgen-right (snode-next-edge bblock))
+ (begin
+ (cgen-right (pnode-consequent-edge bblock))
+ (cgen-right (pnode-alternative-edge bblock)))))
+
+ (define (delay-block bblock edge)
+ (let ((entry
+ (or (assq bblock *pending-bblocks*)
+ (let ((entry
+ (cons bblock
+ (list-transform-positive
+ (node-previous-edges bblock)
+ edge-left-node))))
+ (set! *pending-bblocks*
+ (cons entry
+ *pending-bblocks*))
+ entry))))
+ (let ((dependencies (delq! edge (cdr entry))))
+ (if (not (null? dependencies))
+ (set-cdr! entry dependencies)
+ (begin
+ (set! *pending-bblocks*
+ (delq! entry *pending-bblocks*))
+ (loop bblock
+ (adjust-maps-at-merge! rgraph bblock)))))))
+
+ (define (cgen-right edge)
+ (let ((next (edge-next-node edge)))
+ (if (and next (not (node-marked? next)))
+ (let ((previous (node-previous-edges next)))
+ (cond ((for-all? previous
+ (lambda (edge)
+ (memq edge (rgraph-entry-edges rgraph))))
+ ;; Assumption: no action needed to clear existing
+ ;; register map at this point.
+ (loop next (empty-register-map)))
+ ((and (null? (cdr previous))
+ (edge-left-node (car previous)))
+ (loop
+ next
+ (let ((previous (edge-left-node edge)))
+ (delete-pseudo-registers
+ (bblock-register-map previous)
+ (regset->list
+ (regset-difference (bblock-live-at-exit previous)
+ (bblock-live-at-entry next)))))))
+ (else
+ (delay-block next edge)))))))
+
+ (let ((bblock (edge-right-node edge)))
+ (if (not (there-exists? (node-previous-edges bblock) edge-left-node))
+ (loop bblock (empty-register-map))
+ (delay-block bblock edge))))
+\f
+(define (cgen-bblock bblock map)
+ ;; This procedure is coded out of line to facilitate debugging.
+ (node-mark! bblock)
+ (fluid-let ((*current-bblock* bblock)
+ (*register-map* map)
+ (*preserved-registers* '())
+ (*recomputed-registers* '()))
+ (set-bblock-instructions! bblock
+ (let loop ((rinst (bblock-instructions bblock)))
+ (if (rinst-next rinst)
+ (let ((instructions (cgen-rinst rinst)))
+ (LAP ,@instructions
+ ,@(loop (rinst-next rinst))))
+ (cgen-rinst rinst))))
+ (set-bblock-register-map! bblock *register-map*)))
+
+(define (cgen-rinst rinst)
+ (let loop ((rtl (rinst-rtl rinst))
+ (dead-registers (rinst-dead-registers rinst)))
+ (let ((match-result (lap-generator/match-rtl-instruction rtl)))
+ (cond (match-result
+ (fluid-let ((*dead-registers* dead-registers)
+ (*registers-to-delete* dead-registers)
+ (*prefix-instructions* (LAP))
+ (*suffix-instructions* (LAP))
+ (*needed-registers* '()))
+ (let ((instructions (match-result)))
+ (delete-dead-registers!)
+ (LAP ,@(if *insert-rtl?*
+ (LAP (COMMENT (RTL ,rtl)))
+ (LAP))
+ ,@*prefix-instructions*
+ ,@instructions
+ ,@*suffix-instructions*))))
+ ;; The following presumes that PRESERVE and RESTORE do
+ ;; not match, or, if they do, they are completely handled
+ ;; by the back end.
+ ((eq? (car rtl) 'PRESERVE)
+ (preserve-register!
+ (rtl:register-number (rtl:preserve-register rtl))
+ (rtl:preserve-how rtl))
+ (if *insert-rtl?*
+ (LAP (COMMENT (RTL ,rtl)))
+ (LAP)))
+ ((eq? (car rtl) 'RESTORE)
+ (cgen-restore rtl loop dead-registers))
+ (else
+ (error "CGEN-RINST: No matching rules" rtl)
+ (loop rtl dead-registers))))))
+\f
+(define (cgen-restore rtl loop dead-registers)
+ (let ((restore-reg (rtl:restore-register rtl))
+ (restore-value (rtl:restore-value rtl)))
+ (call-with-values
+ (lambda ()
+ (restored-register-home (rtl:register-number restore-reg)))
+ (lambda (available? reg-where-desired)
+ (let ((instrs
+ (LAP
+ (COMMENT (RESTORING ,restore-reg ,restore-value ,available? ,reg-where-desired))
+ ,@(cond (available?
+ ;; Either has aliases or in register home.
+ (LAP))
+ ((not reg-where-desired)
+ (loop `(ASSIGN ,restore-reg ,restore-value)
+ dead-registers))
+ (else
+ (let* ((code1 (loop
+ `(ASSIGN (REGISTER ,reg-where-desired)
+ ,restore-value)
+ dead-registers))
+ (code2 (loop
+ `(ASSIGN ,restore-reg
+ (REGISTER ,reg-where-desired))
+ '()))
+ (instrs (LAP ,@code1
+ ,@code2)))
+ (release-register! reg-where-desired)
+ instrs))))))
+ (if *insert-rtl?*
+ (LAP (COMMENT (RTL ,rtl))
+ ,@instrs)
+ instrs))))))
+\f
+(define (adjust-maps-at-merge! rgraph bblock)
+ (let* ((edges (list-transform-positive (node-previous-edges bblock)
+ edge-left-node))
+ (maps (map (let ((live-registers (bblock-live-at-entry bblock)))
+ (lambda (edge)
+ (register-map:keep-live-entries
+ (bblock-register-map (edge-left-node edge))
+ live-registers)))
+ edges))
+ (pairs (map cons edges maps))
+ #|
+ (target-map (merge-register-maps maps false))
+ |#
+ (target-map (choose-register-map rgraph pairs)))
+ (for-each
+ (lambda (class)
+ (let ((instructions
+ (coerce-map-instructions (cdar class) target-map)))
+ (if (not (null? instructions))
+ (let ((sblock (make-sblock (LAP (COMMENT MAP MERGE:)
+ ,@instructions))))
+ (node-mark! sblock)
+ (edge-insert-snode! (caar class) sblock)
+ (for-each (lambda (x)
+ (let ((edge (car x)))
+ (edge-disconnect-right! edge)
+ (edge-connect-right! edge sblock)))
+ (cdr class))))))
+ (equivalence-classes pairs
+ (lambda (x y) (map-equal? (cdr x) (cdr y)))))
+ target-map))
+
+(define (equivalence-classes objects predicate)
+ (let ((find-class (association-procedure predicate car)))
+ (let loop ((objects objects) (classes '()))
+ (if (null? objects)
+ classes
+ (let ((class (find-class (car objects) classes)))
+ (if (not class)
+ (loop (cdr objects)
+ (cons (list (car objects)) classes))
+ (begin
+ (set-cdr! class (cons (car objects) (cdr class)))
+ (loop (cdr objects) classes))))))))
+
+(define (choose-register-map rgraph edges&maps)
+ ;; Choose the map corresponding to the "best" edge,
+ ;; and coerce the rest to that shape.
+ ;; For now, a very simple decision,
+ ;; plus, the labels are removed!!
+ rgraph ; ignored
+ (let ((non-continuations (list-transform-positive edges&maps
+ (lambda (edge&map)
+ (let* ((edge (car edge&map))
+ (bblock (edge-left-node edge)))
+ (for-all? (node-previous-edges bblock)
+ edge-left-node))))))
+ (register-map:without-labels
+ (cdr (car (if (null? non-continuations)
+ edges&maps
+ non-continuations))))))
+\f
+(define *cgen-rules* '())
+(define *assign-rules* '())
+(define *assign-variable-rules* '())
+
+(define (add-statement-rule! pattern result-procedure)
+ (let ((result (cons pattern result-procedure)))
+ (cond ((not (eq? (car pattern) 'ASSIGN))
+ (let ((entry (assq (car pattern) *cgen-rules*)))
+ (if entry
+ (set-cdr! entry (cons result (cdr entry)))
+ (set! *cgen-rules*
+ (cons (list (car pattern) result)
+ *cgen-rules*)))))
+ ((not (pattern-variable? (cadr pattern)))
+ (let ((entry (assq (caadr pattern) *assign-rules*)))
+ (if entry
+ (set-cdr! entry (cons result (cdr entry)))
+ (set! *assign-rules*
+ (cons (list (caadr pattern) result)
+ *assign-rules*)))))
+ (else
+ (set! *assign-variable-rules*
+ (cons result *assign-variable-rules*)))))
+ pattern)
+
+(define (lap-generator/match-rtl-instruction rtl)
+ ;; Match a single RTL instruction, returning a thunk to generate the
+ ;; LAP. This is used in the RTL optimizer at certain points to
+ ;; determine if a rewritten instruction is valid.
+ (if (not (rtl:assign? rtl))
+ (let ((rules (assq (rtl:expression-type rtl) *cgen-rules*)))
+ (and rules (pattern-lookup (cdr rules) rtl)))
+ (let ((rules
+ (assq (rtl:expression-type (rtl:assign-address rtl))
+ *assign-rules*)))
+ (or (and rules (pattern-lookup (cdr rules) rtl))
+ (pattern-lookup *assign-variable-rules* rtl)))))
+\f
+;;; Instruction sequence sharing mechanisms
+
+(define *block-associations*)
+
+(define (block-association token)
+ (let ((place (assq token *block-associations*)))
+ (and place (cdr place))))
+
+(define (block-associate! token frob)
+ (set! *block-associations*
+ (cons (cons token frob)
+ *block-associations*))
+ unspecific)
+
+;; This can only be used when the instruction sequences are bit-wise identical.
+;; In other words, no variable registers, constants, etc.
+
+(define (share-instruction-sequence! name if-shared generator)
+ (cond ((block-association name)
+ => if-shared)
+ (else
+ (let ((label (generate-label name)))
+ (block-associate! name label)
+ (generator label)))))
+
+(define (make-new-sblock instructions)
+ (let ((bblock (make-sblock instructions)))
+ (node-mark! bblock)
+ bblock))
+
+(define (current-bblock-continue! bblock)
+ (let ((current-bblock *current-bblock*))
+ (if (sblock-continuation current-bblock)
+ (error "current-bblock-continue! bblock already has a continuation"
+ current-bblock)
+ (begin
+ (create-edge! current-bblock set-snode-next-edge! bblock)
+ (set-bblock-continuations! current-bblock (list bblock))
+ (set-sblock-continuation! current-bblock bblock)))))
+
+(define (lap:comment comment)
+ (if compiler:generate-lap-files?
+ (LAP (COMMENT (LAP ,comment)))
+ (LAP)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: lapgn2.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; LAP Generator: High-Level Register Assignment
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;; `*register-map*' holds the current register map. The operations
+;; that follow use and update this map appropriately, so that the
+;; writer of LAP generator rules need not pass it around.
+
+(define *register-map*)
+(define *preserved-registers*)
+(define *recomputed-registers*)
+
+;; `*needed-registers*' contains a set of machine registers that is
+;; in use during the LAP generation of a single RTL instruction. The
+;; value of this variable is automatically supplied to many low level
+;; register map operations. The set is initialized to the empty set
+;; at the beginning of each instruction. Typically, each alias
+;; register is added to this set as it is allocated. This informs the
+;; register map operations that it is unreasonable to reallocate that
+;; alias for some other purpose for this instruction.
+
+;; The operations that modify `*needed-registers*' assume that `eqv?'
+;; can be used to compare machine registers.
+
+(define *needed-registers*)
+
+(define (need-register! register)
+ (set! *needed-registers* (cons register *needed-registers*)))
+
+(define (need-registers! registers)
+ (set! *needed-registers* (eqv-set-union registers *needed-registers*)))
+
+(define (dont-need-register! register)
+ (set! *needed-registers* (delv! register *needed-registers*)))
+
+(define (dont-need-registers! registers)
+ (set! *needed-registers* (eqv-set-difference *needed-registers* registers)))
+
+;; `*dead-registers*' is initialized at the beginning of each RTL
+;; instruction to the set of pseudo registers that become dead during
+;; that instruction. This information is used to decide whether or
+;; not to keep the contents of a particular pseudo register in a
+;; machine register.
+
+(define *dead-registers*)
+
+(define (dead-register? register)
+ (memv register *dead-registers*))
+
+;; `*registers-to-delete*' is also initialized to the set of pseudo
+;; registers that are dead after the current RTL instruction; these
+;; registers are deleted from the register map after the LAP
+;; generation for that instruction. The LAP generation rules can
+;; cause these deletions to happen at any time by calling
+;; `delete-dead-registers!'.
+
+;; RTL instructions that alter the contents of any pseudo register
+;; must follow this pattern: (1) generate the source operands for the
+;; instruction, (2) delete the dead registers from the register map,
+;; and (3) generate the code for the assignment.
+
+(define *registers-to-delete*)
+
+(define (delete-dead-registers!)
+ (set! *register-map*
+ (delete-pseudo-registers *register-map* *registers-to-delete*))
+ (set! *registers-to-delete* '())
+ unspecific)
+
+;; `*prefix-instructions*' is used to accumulate LAP instructions to
+;; be inserted before the instructions that are the result of the
+;; rule for this RTL instruction. The register map operations
+;; generate these automatically whenever alias registers need to be
+;; loaded or stored, or when the aliases need to be shuffled in some
+;; way.
+
+(define *prefix-instructions*)
+(define *suffix-instructions*)
+
+(define (prefix-instructions! instructions)
+ (set! *prefix-instructions* (LAP ,@*prefix-instructions* ,@instructions)))
+
+(define (suffix-instructions! instructions)
+ (set! *suffix-instructions* (LAP ,@instructions ,@*suffix-instructions*)))
+\f
+;; Register map operations that return `allocator-values' eventually
+;; pass those values to `store-allocator-values!', perhaps after some
+;; tweaking.
+
+(define (store-allocator-values! allocator-values)
+ (bind-allocator-values allocator-values
+ (lambda (alias map instructions)
+ (need-register! alias)
+ (set! *register-map* map)
+ (prefix-instructions! instructions)
+ alias)))
+
+;; Register map operations that return either an alias register or #F
+;; typically are wrapped with a call to `maybe-need-register!' to
+;; record the fact that the returned alias is in use.
+
+(define (maybe-need-register! register)
+ (if register (need-register! register))
+ register)
+
+(define (register-has-alias? register type)
+ ;; True iff `register' has an alias of the given `type'.
+ ;; `register' may be any kind of register.
+ (if (machine-register? register)
+ (register-type? register type)
+ (pseudo-register-alias *register-map* type register)))
+
+(define (alias-is-unique? alias)
+ ;; `alias' must be a valid alias for some pseudo register. This
+ ;; predicate is true iff the pseudo register has no other aliases.
+ (machine-register-is-unique? *register-map* alias))
+
+(define (alias-holds-unique-value? alias)
+ ;; `alias' must be a valid alias for some pseudo register. This
+ ;; predicate is true iff the contents of the pseudo register are not
+ ;; stored anywhere else that the register map knows of.
+ (machine-register-holds-unique-value? *register-map* alias))
+
+(define (is-alias-for-register? potential-alias register)
+ ;; True iff `potential-alias' is a valid alias for `register'.
+ ;; `register' must be a pseudo register, and `potential-alias' must
+ ;; be a machine register.
+ (is-pseudo-register-alias? *register-map* potential-alias register))
+
+(define (register-saved-into-home? register)
+ ;; True iff `register' is known to be saved in its spill temporary.
+ (and (not (machine-register? register))
+ (pseudo-register-saved-into-home? *register-map* register)))
+
+(define (register-alias register type)
+ ;; Returns an alias for `register', of the given `type', if one
+ ;; exists. Otherwise returns #F.
+ (if (machine-register? register)
+ (and (register-type? register type) register)
+ (maybe-need-register!
+ (pseudo-register-alias *register-map* type register))))
+\f
+(define (load-alias-register! register type)
+ ;; Returns an alias for `register', of the given `type'. If no such
+ ;; alias exists, a new alias is assigned and loaded with the correct
+ ;; value, and that alias is returned.
+ (if (machine-register? register)
+ (if (register-type? register type)
+ register
+ (let ((temp (allocate-temporary-register! type)))
+ (prefix-instructions! (register->register-transfer register temp))
+ temp))
+ (store-allocator-values!
+ (load-alias-register *register-map* type *needed-registers* register))))
+
+(define (reference-alias-register! register type)
+ (register-reference (load-alias-register! register type)))
+
+(define (allocate-alias-register! register type)
+ ;; This operation is used to allocate an alias for `register',
+ ;; assuming that it is about to be assigned. It first deletes any
+ ;; other aliases for register, then allocates and returns an alias
+ ;; for `register', of the given `type'.
+ (cond ((not (machine-register? register))
+ (delete-register! register)
+ (store-allocator-values!
+ (allocate-alias-register *register-map*
+ type
+ *needed-registers*
+ register)))
+ ((not (register-type? register type))
+ (delete-register! register)
+ (let ((temp (allocate-temporary-register! type)))
+ (suffix-instructions!
+ (register->register-transfer temp register))
+ temp))
+ ;; *** Lose ***
+ ((not (memq register available-machine-registers))
+ (delete-register! register)
+ register)
+ (else
+ (prefix-instructions! (clean-registers! register))
+ (lock-register! register)
+ register)))
+
+(define (reference-target-alias! register type)
+ (register-reference (allocate-alias-register! register type)))
+
+(define (allocate-temporary-register! type)
+ ;; Allocates a machine register of the given `type' and returns it.
+ ;; This register is not associated with any pseudo register, and can
+ ;; be reallocated for other purposes as soon as it is no longer a
+ ;; member of `*needed-registers*'.
+ (store-allocator-values!
+ (allocate-temporary-register *register-map* type *needed-registers*)))
+
+(define (reference-temporary-register! type)
+ (register-reference (allocate-temporary-register! type)))
+
+(define (add-pseudo-register-alias! register alias)
+ ;; This operation records `alias' as a valid alias for `register'.
+ ;; No instructions are generated. `register' must be a pseudo
+ ;; register, and `alias' must be a previously allocated register
+ ;; (typically for some other pseudo register). Additionally,
+ ;; `alias' must no longer be a valid alias, that is, it must have
+ ;; been deleted from the register map after it was allocated.
+
+ ;; This is extremely useful when performing assignments that move
+ ;; the value of one pseudo register into another, where the former
+ ;; register becomes dead. In this case, since no further reference
+ ;; is made to the source register, it no longer requires any
+ ;; aliases. Thus the target register can "inherit" the alias, which
+ ;; means that the assignment is accomplished without moving any
+ ;; data.
+ (set! *register-map*
+ (add-pseudo-register-alias *register-map* register alias false))
+ (need-register! alias))
+\f
+(define (delete-register! register)
+ ;; Deletes `register' from the register map. No instructions are
+ ;; generated.
+ (if (machine-register? register)
+ (begin
+ (set! *register-map* (delete-machine-register *register-map* register))
+ (dont-need-register! register))
+ (delete-pseudo-register *register-map* register
+ (lambda (map aliases)
+ (set! *register-map* map)
+ (dont-need-registers! aliases)))))
+
+(define (lock-register! register)
+ ;; Makes register unavailable for allocation.
+ ;; No instructions are generated.
+ (set! *register-map* (lock-machine-register *register-map* register))
+ unspecific)
+
+(define (release-register! register)
+ ;; Makes register unavailable for allocation.
+ ;; No instructions are generated.
+ (set! *register-map* (release-machine-register *register-map* register))
+ unspecific)
+\f
+(define (preserve-register! register how)
+ (set! *preserved-registers*
+ (cons (list register how)
+ *preserved-registers*))
+ unspecific)
+
+(define *recompute-me* '(Recompute entry but no fixed alias))
+
+(define (clear-map!/preserving)
+ ;; (values machine-regs pseudo-regs)
+ ;; where machine-regs are the machine registers to preserve,
+ ;; and pseudo-regs are the pseudo registers whose homes
+ ;; must be preserved.
+ ;; It also modifies the register map to reflect the registers
+ ;; needed and available when restoring.
+
+ (define (survive entries)
+ (internal-error "Non-preserved registers survive clear-map!/preserving"
+ entries))
+
+ (delete-dead-registers!)
+ (let ((pairs (map (lambda (entry)
+ (cons (map-entry-home entry)
+ entry))
+ (list-transform-positive (map-entries *register-map*)
+ map-entry-home)))
+ (preserved *preserved-registers*))
+
+ (let ((bad (list-transform-negative pairs
+ (lambda (pair)
+ (assv (car pair) preserved)))))
+ (if (not (null? bad))
+ (survive (map car bad))))
+
+ (let ((entries '())
+ (regs-needed '())
+ (reqs-home '())
+ (regs-reserved '()))
+
+ (define (save-aliases entry)
+ (let ((aliases (map-entry-aliases entry)))
+ (set! regs-needed (eqv-set-union aliases regs-needed))
+ (set! entries
+ (cons (if (map-entry-saved-into-home? entry)
+ (make-map-entry (map-entry-home entry)
+ false
+ aliases
+ false)
+ entry)
+ entries))
+ unspecific))
+
+ (define (remember-an-alias entry)
+ ;; Called only when guaranteed that there is an alias!
+ (let ((reserved (car (map-entry-aliases entry))))
+ (set! regs-reserved (eqv-set-adjoin reserved regs-reserved))
+ (set! entries
+ (cons (make-map-entry (map-entry-home entry)
+ reserved
+ '()
+ false)
+ entries))
+ unspecific))
+
+
+ (define (remember-to-recompute register)
+ (set! entries
+ (cons (make-map-entry register
+ *recompute-me*
+ '()
+ false)
+ entries))
+ unspecific)
+\f
+ (let loop ((preserved preserved))
+ (if (null? preserved)
+ (begin
+ (set! *needed-registers* regs-needed)
+ (set! *register-map*
+ (make-register-map
+ entries
+ (eqv-set-difference
+ (eqv-set-difference available-machine-registers
+ regs-needed)
+ regs-reserved)))
+ (values regs-needed reqs-home))
+ (let* ((how (cadr (car preserved)))
+ (reg (car (car preserved)))
+ (entry (let ((pair (assv reg pairs)))
+ (and pair (cdr pair))))
+ (has-alias?
+ (and entry
+ (not (null? (map-entry-aliases entry))))))
+ (case how
+ ((SAVE)
+ (if has-alias?
+ (save-aliases entry)
+ (begin
+ (set! reqs-home (cons reg reqs-home))
+ (set! entries
+ (cons (or entry
+ (make-map-entry reg
+ true
+ '()
+ false))
+ entries)))))
+ ((IF-AVAILABLE)
+ (if has-alias?
+ (save-aliases entry)))
+ ((RECOMPUTE)
+ (if has-alias?
+ (remember-an-alias entry)
+ (remember-to-recompute reg)))
+ (else
+ (error "Unknown preservation kind" how)))
+ (loop (cdr preserved))))))))
+
+(define (restore-registers!)
+ ;; This is called as part of processing (RETURN-ADDRESS ...);
+ ;; it is *NOT* what is used to handle (RESTORE ...): that code
+ ;; is in CGEN-RINST and CGEN-RESTORE.
+ (call-with-values
+ (lambda ()
+ (list-split (map-entries *register-map*)
+ (lambda (entry)
+ (boolean? (map-entry-saved-into-home? entry)))))
+ (lambda (normal alias-remembered)
+ (call-with-values
+ (lambda ()
+ (list-split alias-remembered
+ (lambda (entry)
+ (eq? (map-entry-saved-into-home? entry)
+ *recompute-me*))))
+ (lambda (no-alias have-alias)
+ (set! *recomputed-registers*
+ ;; (Home Alias) pairs or (Home #F) if no fixed alias
+ (append
+ (map (lambda (entry)
+ (list (map-entry-home entry)
+ (map-entry-saved-into-home? entry)))
+ have-alias)
+ (map (lambda (entry)
+ (list (map-entry-home entry) #F))
+ no-alias)))
+ (set! *register-map*
+ (make-register-map normal
+ (map-registers:add*
+ (map-registers *register-map*)
+ (map map-entry-saved-into-home?
+ have-alias))))))))
+ unspecific)
+
+(define (restored-register-home register)
+ ;; (values available? reg-where-desired)
+ (let* ((info (assq register *recomputed-registers*))
+ (alias (and info (cadr info))))
+ (cond (alias (values false alias)) ; RECOMPUTE, had alias
+ (info (values false false)) ; RECOMPUTE, no alias
+ ((or (register-has-alias? register false)
+ (register-saved-into-home? register)) ; Available
+ (values true (list (register-has-alias? register false)
+ (register-saved-into-home? register))))
+ (else (values false false)))))
+\f
+(define (clear-map!)
+ ;; Deletes all registers from the register map. Generates and
+ ;; returns instructions to save pseudo registers into their homes,
+ ;; if necessary. This is typically used just before a control
+ ;; transfer to somewhere that can potentially flush the contents of
+ ;; the machine registers.
+ (delete-dead-registers!)
+ (if (not (null? *preserved-registers*))
+ (error "clear-map! called with registers preserved"
+ *preserved-registers*))
+ (clear-map!/finish (clear-map)))
+
+(define (clear-map!/finish instructions)
+ (set! *register-map* (empty-register-map))
+ (set! *needed-registers* '())
+ instructions)
+
+(define (clear-map)
+ (clear-map-instructions *register-map*))
+
+(define (clear-registers! . registers)
+ (if (null? registers)
+ '()
+ (let loop ((map *register-map*) (registers registers))
+ (save-machine-register map (car registers)
+ (lambda (map instructions)
+ (let ((map (delete-machine-register map (car registers))))
+ (if (null? (cdr registers))
+ (begin
+ (set! *register-map* map)
+ instructions)
+ (append! instructions (loop map (cdr registers))))))))))
+
+(define (clean-registers! . aregisters)
+ (if (null? aregisters)
+ '()
+ (let loop ((map *register-map*) (registers aregisters))
+ (preserve-machine-register map (car registers)
+ (eq-set-union aregisters *needed-registers*)
+ (lambda (map instructions)
+ (let ((map (delete-machine-register map (car registers))))
+ (if (null? (cdr registers))
+ (begin
+ (set! *register-map* map)
+ instructions)
+ (append! instructions (loop map (cdr registers))))))))))
+\f
+(define (standard-register-reference register preferred-type alternate-types?)
+ ;; Generate a standard reference for `register'. This procedure
+ ;; uses a number of heuristics, aided by `preferred-type', to
+ ;; determine the optimum reference. This should be used only when
+ ;; the reference need not have any special properties, as the result
+ ;; is not even guaranteed to be a register reference.
+ (if (machine-register? register)
+ (if alternate-types?
+ (register-reference register)
+ (reference-alias-register! register preferred-type))
+ (let ((no-reuse-possible
+ (lambda ()
+ ;; If there are no aliases, and the register is not dead,
+ ;; allocate an alias of the preferred type. This is
+ ;; desirable because the register will be used again.
+ ;; Otherwise, this is the last use of this register, so we
+ ;; might as well just use the register's home.
+ (if (and (register-saved-into-home? register)
+ (or (dead-register? register)
+ (not (allocate-register-without-unload?
+ *register-map*
+ preferred-type
+ *needed-registers*))))
+ (pseudo-register-home register)
+ (reference-alias-register! register preferred-type)))))
+ (let ((no-preference
+ (lambda ()
+ ;; Next, attempt to find an alias of any type.
+ (let ((alias (register-alias register false)))
+ (if alias
+ (register-reference alias)
+ (no-reuse-possible))))))
+ ;; First, attempt to find an alias of the preferred type.
+ (if preferred-type
+ (let ((alias (register-alias register preferred-type)))
+ (cond (alias (register-reference alias))
+ (alternate-types? (no-preference))
+ (else (no-reuse-possible))))
+ (no-preference))))))
+
+(define (%load-machine-register! source-register machine-register
+ clean-register-map!)
+ ;; Copy the contents of `source-register' to `machine-register'.
+ (cond ((machine-register? source-register)
+ (clean-register-map!)
+ (LAP ,@(clean-registers! machine-register)
+ ,@(if (eqv? source-register machine-register)
+ (LAP)
+ (register->register-transfer source-register
+ machine-register))))
+ ((is-alias-for-register? machine-register source-register)
+ (clean-register-map!)
+ (clean-registers! machine-register))
+ (else
+ (let ((source-reference
+ (if (register-value-class=word? source-register)
+ (standard-register-reference source-register false true)
+ (standard-register-reference
+ source-register
+ (register-type source-register)
+ false))))
+ (clean-register-map!)
+ (LAP ,@(clean-registers! machine-register)
+ ,@(reference->register-transfer source-reference
+ machine-register))))))
+
+(define (load-machine-register! source-register machine-register)
+ ;; Copy the contents of `source-register' to `machine-register'.
+ (%load-machine-register! source-register machine-register
+ (lambda () unspecific)))
+\f
+(define (move-to-alias-register! source type target)
+ ;; Performs an assignment from register `source' to register
+ ;; `target', allocating an alias for `target' of the given `type';
+ ;; returns that alias. If `source' has a reusable alias of the
+ ;; appropriate type, that is used, in which case no instructions are
+ ;; generated.
+ (cond ((and (machine-register? target)
+ (register-type? target type))
+ ;; *** Lose ***
+ ;; The following is done wrong on several counts:
+ ;; 1: memq should not be used, a vector of all machine registers
+ ;; containing booleans can be used instead.
+ ;; 2: lock-register! should wire down the register as being
+ ;; a "permanent" alias for source, since the pseudo register
+ ;; may still be referenced. The register map abstraction
+ ;; needs to be extended for this.
+ (cond ((not (memq target available-machine-registers))
+ (prefix-instructions!
+ (reference->register-transfer
+ (standard-register-reference source type true)
+ target)))
+ ((not (is-alias-for-register? target source))
+ (prefix-instructions!
+ (%load-machine-register! source target
+ delete-dead-registers!))
+ (lock-register! target))
+ (else
+ ;; *** The following may cause a cascade of copies
+ ;; since the following machine register assignment
+ ;; may assign to the register just picked. ***
+ (delete-dead-registers!)
+ (prefix-instructions! (clean-registers! target))
+ (lock-register! target)))
+ target)
+ ((and (machine-register? source)
+ (register-type? source type)
+ ;; *** Lose ***
+ (memq source available-machine-registers))
+ (delete-register! target)
+ (add-pseudo-register-alias! target source)
+ source)
+ (else
+ (reuse-pseudo-register-alias!
+ source type
+ (lambda (alias)
+ (delete-dead-registers!)
+ (if (machine-register? target)
+ (suffix-instructions!
+ (register->register-transfer alias target))
+ (add-pseudo-register-alias! target alias))
+ alias)
+ (lambda ()
+ (let ((source (standard-register-reference source type true)))
+ (delete-dead-registers!)
+ (let ((target (allocate-alias-register! target type)))
+ (prefix-instructions!
+ (reference->register-transfer source target))
+ target)))))))
+\f
+(define (move-to-temporary-register! source type)
+ ;; Allocates a temporary register, of the given `type', and loads
+ ;; the contents of the register `source' into it. Returns a
+ ;; reference to that temporary. If `source' has a reusable alias of
+ ;; the appropriate type, that is used, in which case no instructions
+ ;; are generated.
+ (reuse-pseudo-register-alias! source type
+ (lambda (alias)
+ (need-register! alias)
+ alias)
+ (lambda ()
+ (let ((target (allocate-temporary-register! type)))
+ (prefix-instructions!
+ (reference->register-transfer
+ (standard-register-reference source type true)
+ target))
+ target))))
+
+(define (reuse-pseudo-register-alias! source type if-reusable if-not)
+ (reuse-pseudo-register-alias source type
+ (lambda (alias)
+ (delete-register! alias)
+ (if-reusable alias))
+ if-not))
+
+(define (reuse-pseudo-register-alias source type if-reusable if-not)
+ ;; Attempts to find a reusable alias for `source', of the given
+ ;; `type'. If one is found, `if-reusable' is tail-recursively
+ ;; invoked on it. Otherwise, `if-not' is tail-recursively invoked
+ ;; with no arguments. The heuristics used to decide if an alias is
+ ;; reusable are as follows: (1) if `source' is dead, any of its
+ ;; aliases may be reused, and (2) if `source' is live with multiple
+ ;; aliases, then one of its aliases may be reused.
+ (if (machine-register? source)
+ (if-not)
+ (let ((alias (register-alias source type)))
+ (cond ((not alias)
+ (if-not))
+ ((dead-register? source)
+ (if-reusable alias))
+ ((not (alias-is-unique? alias))
+ (if-reusable alias))
+ (else
+ (if-not))))))
+\f
+;;; The following procedures are used when the copy is going to be
+;;; transformed, and the machine has 3 operand instructions, which
+;;; allow an implicit motion in the transformation operation.
+
+;;; For example, on the DEC VAX it is cheaper to do
+;;; bicl3 op1,source,target
+;;; than
+;;; movl source,target
+;;; bicl2 op1,target
+
+;;; The extra arguments are
+;;; REC1, invoked if we are reusing an alias of source.
+;;; It already contains the data to operate on.
+;;; REC2, invoked if a `brand-new' alias for target has been allocated.
+;;; We must take care of moving the data ourselves.
+
+(define (with-register-copy-alias! source type target rec1 rec2)
+ (if (and (machine-register? target)
+ (register-type? target type))
+ (let* ((source (standard-register-reference source type true))
+ (target (register-reference target)))
+ (rec2 source target))
+ (reuse-pseudo-register-alias! source type
+ (lambda (alias)
+ (delete-dead-registers!)
+ (if (machine-register? target)
+ (suffix-instructions! (register->register-transfer alias target))
+ (add-pseudo-register-alias! target alias))
+ (rec1 (register-reference alias)))
+ (lambda ()
+ (let ((source (standard-register-reference source type true)))
+ (delete-dead-registers!)
+ (rec2 source (reference-target-alias! target type)))))))
+
+(define (with-temporary-register-copy! source type rec1 rec2)
+ (reuse-pseudo-register-alias! source type
+ (lambda (alias)
+ (need-register! alias)
+ (rec1 (register-reference alias)))
+ (lambda ()
+ (rec2 (standard-register-reference source type true)
+ (reference-temporary-register! type)))))
+
+(define (register-copy-if-available source type target)
+ (and (not (machine-register? target))
+ (reuse-pseudo-register-alias source type
+ (lambda (reusable-alias)
+ (lambda ()
+ (delete-register! reusable-alias)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target reusable-alias)
+ (register-reference reusable-alias)))
+ (lambda () false))))
+
+(define (temporary-copy-if-available source type)
+ (reuse-pseudo-register-alias source type
+ (lambda (reusable-alias)
+ (lambda ()
+ (delete-register! reusable-alias)
+ (need-register! reusable-alias)
+ (register-reference reusable-alias)))
+ (lambda () false)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: lapgn3.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1987-1992 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. |#
+
+;;;; LAP Generator
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Constants
+
+(define *next-constant*)
+(define *interned-constants*)
+(define *interned-variables*)
+(define *interned-assignments*)
+(define *interned-uuo-links*)
+(define *interned-global-links*)
+(define *interned-static-variables*)
+
+(define (allocate-named-label prefix)
+ (let ((label
+ (string->uninterned-symbol
+ (string-append prefix (number->string *next-constant*)))))
+ (set! *next-constant* (1+ *next-constant*))
+ label))
+
+(define (allocate-constant-label)
+ (allocate-named-label "CONSTANT-"))
+
+(define (warning-assoc obj pairs)
+ (define (local-eqv? obj1 obj2)
+ (or (eqv? obj1 obj2)
+ (and (string? obj1)
+ (string? obj2)
+ (zero? (string-length obj1))
+ (zero? (string-length obj2)))))
+
+ (let ((pair (assoc obj pairs)))
+ (if (and compiler:coalescing-constant-warnings?
+ (pair? pair)
+ (not (local-eqv? obj (car pair))))
+ (warn "Coalescing two copies of constant object" obj))
+ pair))
+
+(define-integrable (object->label find read write allocate-label)
+ (lambda (object)
+ (let ((entry (find object (read))))
+ (if entry
+ (cdr entry)
+ (let ((label (allocate-label object)))
+ (write (cons (cons object label)
+ (read)))
+ label)))))
+
+(let-syntax ((->label
+ (macro (find var #!optional suffix)
+ `(object->label ,find
+ (lambda () ,var)
+ (lambda (new)
+ (declare (integrate new))
+ (set! ,var new))
+ ,(if (default-object? suffix)
+ `(lambda (object)
+ object ; ignore
+ (allocate-named-label "OBJECT-"))
+ `(lambda (object)
+ (allocate-named-label
+ (string-append (symbol->string object)
+ ,suffix))))))))
+(define constant->label
+ (->label warning-assoc *interned-constants*))
+
+(define free-reference-label
+ (->label assq *interned-variables* "-READ-CELL-"))
+
+(define free-assignment-label
+ (->label assq *interned-assignments* "-WRITE-CELL-"))
+
+(define free-static-label
+ (->label assq *interned-static-variables* "-HOME-"))
+
+;; End of let-syntax
+)
+\f
+;; These are different because different uuo-links are used for different
+;; numbers of arguments.
+
+(define (allocate-uuo-link-label prefix name frame-size)
+ (allocate-named-label
+ (string-append prefix
+ (symbol->string name)
+ "-"
+ (number->string (-1+ frame-size))
+ "-ARGS-")))
+
+(define-integrable (uuo-link-label read write! prefix)
+ (lambda (name frame-size)
+ (let* ((all (read))
+ (entry (assq name all)))
+ (if entry
+ (let ((place (assv frame-size (cdr entry))))
+ (if place
+ (cdr place)
+ (let ((label (allocate-uuo-link-label prefix name frame-size)))
+ (set-cdr! entry
+ (cons (cons frame-size label)
+ (cdr entry)))
+ label)))
+ (let ((label (allocate-uuo-link-label prefix name frame-size)))
+ (write! (cons (list name (cons frame-size label))
+ all))
+ label)))))
+
+(define free-uuo-link-label
+ (uuo-link-label (lambda () *interned-uuo-links*)
+ (lambda (new)
+ (set! *interned-uuo-links* new))
+ ""))
+
+(define global-uuo-link-label
+ (uuo-link-label (lambda () *interned-global-links*)
+ (lambda (new)
+ (set! *interned-global-links* new))
+ "GLOBAL-"))
+
+(define (prepare-constants-block)
+ (generate/constants-block *interned-constants*
+ *interned-variables*
+ *interned-assignments*
+ *interned-uuo-links*
+ *interned-global-links*
+ *interned-static-variables*))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: linear.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; LAP linearizer
+;;; package: (compiler lap-syntaxer linearizer)
+
+(declare (usual-integrations))
+\f
+(define *strongly-heed-branch-preferences?* false)
+
+(define (bblock-linearize-lap bblock queue-continuations!)
+ (define (linearize-bblock bblock)
+ (LAP ,@(linearize-bblock-1 bblock)
+ ,@(linearize-next bblock)))
+
+ (define (linearize-bblock-1 bblock)
+ (node-mark! bblock)
+ (queue-continuations! bblock)
+ (if (and (not (bblock-label bblock))
+ (let loop ((bblock bblock))
+ (or (node-previous>1? bblock)
+ (and (node-previous=1? bblock)
+ (let ((previous (node-previous-first bblock)))
+ (and (sblock? previous)
+ (null? (bblock-instructions previous))
+ (loop previous)))))))
+ (bblock-label! bblock))
+ (let ((kernel
+ (lambda ()
+ (bblock-instructions bblock))))
+ (if (bblock-label bblock)
+ (LAP ,@(lap:make-label-statement (bblock-label bblock)) ,@(kernel))
+ (kernel))))
+
+ (define (linearize-next bblock)
+ (if (sblock? bblock)
+ (let ((next (find-next (snode-next bblock))))
+ (if next
+ (linearize-sblock-next next (bblock-label next))
+ (let ((bblock (sblock-continuation bblock)))
+ (if (and bblock (not (node-marked? bblock)))
+ (linearize-bblock bblock)
+ (LAP)))))
+ (linearize-pblock
+ bblock
+ (find-next (pnode-consequent bblock))
+ (find-next (pnode-alternative bblock)))))
+
+ (define (linearize-sblock-next bblock label)
+ (if (node-marked? bblock)
+ (lap:make-unconditional-branch label)
+ (linearize-bblock bblock)))
+
+ (define (linearize-pblock pblock cn an)
+ (if (node-marked? cn)
+ (if (node-marked? an)
+ (heed-preference pblock cn an
+ (lambda (generator cn an)
+ (LAP ,@(generator (bblock-label cn))
+ ,@(lap:make-unconditional-branch (bblock-label an)))))
+ (LAP ,@((pblock-consequent-lap-generator pblock)
+ (bblock-label cn))
+ ,@(linearize-bblock an)))
+ (if (node-marked? an)
+ (LAP ,@((pblock-alternative-lap-generator pblock)
+ (bblock-label an))
+ ,@(linearize-bblock cn))
+ (linearize-pblock-1 pblock cn an))))
+\f
+ (define (linearize-pblock-1 pblock cn an)
+ (let ((finish
+ (lambda (generator cn an)
+ (let ((clabel (bblock-label! cn))
+ (alternative (linearize-bblock an)))
+ (LAP ,@(generator clabel)
+ ,@alternative
+ ,@(if (node-marked? cn)
+ (LAP)
+ (linearize-bblock cn)))))))
+ (let ((consequent-first
+ (lambda ()
+ (finish (pblock-alternative-lap-generator pblock) an cn)))
+ (alternative-first
+ (lambda ()
+ (finish (pblock-consequent-lap-generator pblock) cn an)))
+ (unspecial
+ (lambda ()
+ (heed-preference pblock cn an finish)))
+ (diamond
+ (lambda ()
+ (let ((jlabel (generate-label)))
+ (heed-preference pblock cn an
+ (lambda (generator cn an)
+ (let ((clabel (bblock-label! cn)))
+ (let ((consequent (linearize-bblock-1 cn))
+ (alternative (linearize-bblock-1 an)))
+ (LAP ,@(generator clabel)
+ ,@alternative
+ ,@(lap:make-unconditional-branch jlabel)
+ ,@consequent
+ ,@(lap:make-label-statement jlabel)
+ ,@(linearize-next cn))))))))))
+\f
+ (lap:mark-preferred-branch! pblock cn an)
+ (cond ((eq? cn an)
+ (warn "bblock-linearize-lap: Identical branches" pblock)
+ (unspecial))
+ ((and *strongly-heed-branch-preferences?*
+ (pnode/preferred-branch pblock))
+ (unspecial))
+ ((sblock? cn)
+ (let ((cnn (find-next (snode-next cn))))
+ (cond ((eq? cnn an)
+ (consequent-first))
+ ((sblock? an)
+ (let ((ann (find-next (snode-next an))))
+ (cond ((eq? ann cn)
+ (alternative-first))
+ ((not cnn)
+ (if ann
+ (consequent-first)
+ (if (null? (bblock-continuations cn))
+ (if (null? (bblock-continuations an))
+ (unspecial)
+ (consequent-first))
+ (if (null? (bblock-continuations an))
+ (alternative-first)
+ (unspecial)))))
+ ((not ann)
+ (alternative-first))
+ ((eq? cnn ann)
+ (diamond))
+ (else
+ (unspecial)))))
+ ((not cnn)
+ (consequent-first))
+ (else
+ (unspecial)))))
+ ((and (sblock? an)
+ (let ((ann (find-next (snode-next an))))
+ (or (not ann)
+ (eq? ann cn))))
+ (alternative-first))
+ (else
+ (unspecial))))))
+
+ (define (heed-preference pblock cn an finish)
+ (if (eq? 'CONSEQUENT (pnode/preferred-branch pblock))
+ (finish (pblock-alternative-lap-generator pblock) an cn)
+ (finish (pblock-consequent-lap-generator pblock) cn an)))
+
+ (define (find-next bblock)
+ (let loop ((bblock bblock) (previous false))
+ (cond ((not bblock)
+ previous)
+ ((and (sblock? bblock)
+ (null? (bblock-instructions bblock)))
+ (loop (snode-next bblock) bblock))
+ (else
+ bblock))))
+
+ (linearize-bblock bblock))
+\f
+(define-integrable (set-current-branches! consequent alternative)
+ (set-pblock-consequent-lap-generator! *current-bblock* consequent)
+ (set-pblock-alternative-lap-generator! *current-bblock* alternative))
+
+(define *end-of-block-code*)
+
+(define-structure (extra-code-block
+ (conc-name extra-code-block/)
+ (constructor extra-code-block/make
+ (name constraint xtra)))
+ (name false read-only true)
+ (constraint false read-only true)
+ (code (LAP) read-only false)
+ (xtra false read-only false))
+
+(define linearize-lap
+ (make-linearizer bblock-linearize-lap
+ (lambda () (LAP))
+ (lambda (x y) (LAP ,@x ,@y))
+ (lambda (linearized-lap)
+ (let ((end-code *end-of-block-code*))
+ (set! *end-of-block-code* '())
+ (LAP ,@linearized-lap
+ ,@(let process ((end-code end-code))
+ (if (null? end-code)
+ (LAP)
+ (LAP ,@(extra-code-block/code (car end-code))
+ ,@(process (cdr end-code))))))))))
+
+(define (find-extra-code-block name)
+ (let loop ((end-code *end-of-block-code*))
+ (cond ((null? end-code) false)
+ ((eq? name (extra-code-block/name (car end-code)))
+ (car end-code))
+ (else
+ (loop (cdr end-code))))))
+\f
+(define (declare-extra-code-block! name constraint xtra)
+ (if (find-extra-code-block name)
+ (error "declare-extra-code-block!: Multiply defined block"
+ name)
+ (let ((new (extra-code-block/make name constraint xtra))
+ (all *end-of-block-code*))
+
+ (define (constraint-violation new old)
+ (error "declare-extra-code-block!: Inconsistent constraints"
+ new old))
+
+ (case constraint
+ ((FIRST)
+ (if (and (not (null? all))
+ (eq? 'FIRST
+ (extra-code-block/constraint (car all))))
+ (constraint-violation new (car all)))
+ (set! *end-of-block-code* (cons new all)))
+ ((ANYWHERE)
+ (if (or (null? all)
+ (not (eq? 'FIRST
+ (extra-code-block/constraint (car all)))))
+ (set! *end-of-block-code* (cons new all))
+ (set-cdr! all (cons new (cdr all)))))
+ ((LAST)
+ (if (null? all)
+ (set! *end-of-block-code* (list new))
+ (let* ((lp (last-pair all))
+ (old (car lp)))
+ (if (eq? 'LAST (extra-code-block/constraint old))
+ (constraint-violation new old))
+ (set-cdr! lp (cons new '())))))
+ (else
+ (error "declare-extra-code-block!: Unknown constraint"
+ constraint)))
+ new)))
+
+(define (add-extra-code! block new-code)
+ (set-extra-code-block/code!
+ block
+ (LAP ,@(extra-code-block/code block)
+ ,@new-code)))
+
+(define (add-end-of-block-code! code-thunk)
+ (add-extra-code!
+ (or (find-extra-code-block 'END-OF-BLOCK)
+ (declare-extra-code-block! 'END-OF-BLOCK 'ANYWHERE false))
+ (code-thunk)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: mermap.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; LAP Generator: Merge Register Maps
+;; package: (compiler lap-syntaxer map-merger)
+
+(declare (usual-integrations))
+\f
+(define (merge-register-maps maps weights)
+ ;; This plays merry hell with the map entry order. An attempt has
+ ;; been made to preserve the order in simple cases, but in general
+ ;; there isn't enough information to do a really good job.
+ (let ((entries
+ (reduce add-weighted-entries
+ '()
+ (if (not weights)
+ (map (lambda (map) (map->weighted-entries map 1)) maps)
+ (map map->weighted-entries maps weights)))))
+ (for-each eliminate-unlikely-aliases! entries)
+ (eliminate-conflicting-aliases! entries)
+ (weighted-entries->map (car maps) entries)))
+
+(define (eliminate-unlikely-aliases! entry)
+ (let ((home-weight (vector-ref entry 1))
+ (alias-weights (vector-ref entry 2)))
+ (let ((maximum (max home-weight (apply max (map cdr alias-weights)))))
+ (if (not (= home-weight maximum))
+ (vector-set! entry 1 0))
+ ;; Keep only the aliases with the maximum weights. Furthermore,
+ ;; keep only one alias of a given type.
+ (vector-set! entry 2
+ (list-transform-positive alias-weights
+ (let ((types '()))
+ (lambda (alias-weight)
+ (and (= (cdr alias-weight) maximum)
+ (let ((type (register-type (car alias-weight))))
+ (and (not (memq type types))
+ (begin (set! types (cons type types))
+ true)))))))))))
+
+(define (eliminate-conflicting-aliases! entries)
+ (for-each (lambda (conflicting-alias)
+ (let ((homes (cdr conflicting-alias)))
+ (let ((maximum (apply max (map cdr homes))))
+ (let ((winner
+ (list-search-positive homes
+ (lambda (home)
+ (= (cdr home) maximum)))))
+ (for-each
+ (lambda (home)
+ (if (not (eq? home winner))
+ (let ((entry
+ (find-weighted-entry (car home) entries)))
+ (vector-set! entry 2
+ (del-assv! (car conflicting-alias)
+ (vector-ref entry 2))))))
+ homes)))))
+ (conflicting-aliases entries)))
+
+(define (conflicting-aliases entries)
+ (let ((alist '()))
+ (for-each
+ (lambda (entry)
+ (let ((home (vector-ref entry 0)))
+ (for-each
+ (lambda (alias-weight)
+ (let ((alist-entry (assv (car alias-weight) alist))
+ (element (cons home (cdr alias-weight))))
+ (if alist-entry
+ (set-cdr! alist-entry (cons element (cdr alist-entry)))
+ (set! alist
+ (cons (list (car alias-weight) element) alist)))))
+ (vector-ref entry 2))))
+ entries)
+ (list-transform-negative alist
+ (lambda (alist-entry)
+ (null? (cddr alist-entry))))))
+\f
+(define (map->weighted-entries register-map weight)
+ (map (lambda (entry)
+ (vector (map-entry-home entry)
+ (if (map-entry-saved-into-home? entry) weight 0)
+ (map (lambda (alias) (cons alias weight))
+ (map-entry-aliases entry))
+ (map-entry-label entry)))
+ (map-entries register-map)))
+
+(define (add-weighted-entries x-entries y-entries)
+ (merge-entries x-entries y-entries
+ (lambda (entry entries)
+ (list-search-positive entries
+ (let ((home (vector-ref entry 0)))
+ (lambda (entry)
+ (eqv? home (vector-ref entry 0))))))
+ (lambda (x-entry y-entry)
+ (vector (vector-ref x-entry 0)
+ (+ (vector-ref x-entry 1) (vector-ref y-entry 1))
+ (merge-entries (vector-ref x-entry 2) (vector-ref y-entry 2)
+ (lambda (entry entries)
+ (assq (car entry) entries))
+ (lambda (x-entry y-entry)
+ (cons (car x-entry) (+ (cdr x-entry) (cdr y-entry)))))
+ ;; If the labels don't match, or only one entry has a
+ ;; label, then the result shouldn't have a label.
+ (and (eqv? (vector-ref x-entry 3) (vector-ref y-entry 3))
+ (vector-ref x-entry 3))))))
+
+(define (merge-entries x-entries y-entries find-entry merge-entry)
+ (let loop
+ ((x-entries x-entries)
+ (y-entries (list-copy y-entries))
+ (result '()))
+ (if (null? x-entries)
+ ;; This (feebly) attempts to preserve the entry order.
+ (append! (reverse! result) y-entries)
+ (let ((x-entry (car x-entries))
+ (x-entries (cdr x-entries)))
+ (let ((y-entry (find-entry x-entry y-entries)))
+ (if y-entry
+ (loop x-entries
+ (delq! y-entry y-entries)
+ (cons (merge-entry x-entry y-entry) result))
+ (loop x-entries
+ y-entries
+ (cons x-entry result))))))))
+
+(define find-weighted-entry
+ (association-procedure eqv? (lambda (entry) (vector-ref entry 0))))
+
+(define (weighted-entries->map map entries)
+ (let loop
+ ((entries entries)
+ (map-entries '())
+ (map-registers available-machine-registers))
+ (if (null? entries)
+ (make-register-map (reverse! map-entries)
+ (sort-machine-registers map-registers))
+ (let ((aliases (map car (vector-ref (car entries) 2))))
+ (if (null? aliases)
+ (loop (cdr entries) map-entries map-registers)
+ (loop (cdr entries)
+ (cons (make-map-entry
+ (vector-ref (car entries) 0)
+ (positive? (vector-ref (car entries) 1))
+ aliases
+ (vector-ref (car entries) 3))
+ map-entries)
+ (eqv-set-difference map-registers aliases)))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: regmap.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; Register Allocator
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+#|
+
+The register allocator provides a mechanism for allocating and
+deallocating machine registers. It manages the available machine
+registers as a cache, by maintaining a "map" that records two kinds of
+information: (1) a list of the machine registers that are not in use;
+and (2) a mapping that is the association between the allocated
+machine registers and the "pseudo registers" that they represent.
+
+An "alias" is a machine register that also holds the contents of a
+pseudo register. Usually an alias is used for a short period of time,
+as a store-in cache, and then eventually the contents of the alias is
+written back out to the home it is associated with. Because of the
+lifetime analysis, it is possible to identify those registers that
+will no longer be referenced; these are deleted from the map when they
+die, and thus do not need to be saved.
+
+A "temporary" is a machine register with no associated home. It is
+used during the code generation of a single RTL instruction to hold
+intermediate results.
+
+Each pseudo register that has at least one alias has an entry in the
+map. While a home is entered in the map, it may have one or more
+aliases added or deleted to its entry, but if the number of aliases
+ever drops to zero, the entry is removed from the map.
+
+Each temporary has an entry in the map, with the difference being that
+the entry has no pseudo register associated with it. Thus it need
+never be written out.
+
+All registers, both machine and pseudo, are represented by
+non-negative integers. Machine registers start at zero (inclusive)
+and stop at `number-of-machine-registers' (exclusive). All others are
+pseudo registers. Because they are integers, we can use `eqv?' to
+compare register numbers.
+
+`available-machine-registers' should be a list of the registers that
+the allocator is allowed to allocate, in the preferred order of
+allocation.
+
+`(sort-machine-registers registers)' should reorder a list of machine
+registers into some interesting sorting order.
+
+|#
+
+(define (register-type? register type)
+ (if type
+ (eq? type (register-type register))
+ (register-value-class=word? register)))
+
+(define ((register-type-predicate type) register)
+ (register-type? register type))
+\f
+;;;; Register Map
+
+(define-integrable make-register-map cons)
+(define-integrable map-entries car)
+(define-integrable map-registers cdr)
+
+(define (empty-register-map)
+ (make-register-map '() available-machine-registers))
+
+(define (map-entries:search map procedure)
+ ;; This procedure is used only when attempting to free up an
+ ;; existing register. Because of this, it must find an LRU
+ ;; register. Since we order the map entries starting with the MRU
+ ;; registers and working towards the LRU, search the entries
+ ;; starting from the end of the list and working forward.
+ (let loop ((entries (map-entries map)))
+ (and (not (null? entries))
+ (or (loop (cdr entries))
+ (procedure (car entries))))))
+
+(define (map-entries:find-home map pseudo-register)
+ (let loop ((entries (map-entries map)))
+ (and (not (null? entries))
+ (or (and (map-entry-home (car entries))
+ (eqv? (map-entry-home (car entries)) pseudo-register)
+ (car entries))
+ (loop (cdr entries))))))
+
+(define (map-entries:find-alias map register)
+ (let loop ((entries (map-entries map)))
+ (and (not (null? entries))
+ ;; **** Kludge -- depends on fact that machine registers are
+ ;; fixnums, and thus EQ? works on them.
+ (or (and (memq register (map-entry-aliases (car entries)))
+ (car entries))
+ (loop (cdr entries))))))
+
+(define-integrable (map-entries:add map entry)
+ (cons entry (map-entries map)))
+
+(define-integrable (map-entries:delete map entry)
+ (eq-set-delete (map-entries map) entry))
+
+(define-integrable (map-entries:delete* map entries)
+ (eq-set-difference (map-entries map) entries))
+
+(define (map-entries:replace map old new)
+ (let loop ((entries (map-entries map)))
+ (if (null? entries)
+ '()
+ (cons (if (eq? (car entries) old) new (car entries))
+ (loop (cdr entries))))))
+
+(define (map-entries:replace&touch map old new)
+ (cons new (map-entries:delete map old)))
+
+(define-integrable (map-registers:add map register)
+ (sort-machine-registers (append (map-registers map) (list register))))
+
+(define-integrable (map-registers:add* map registers)
+ (sort-machine-registers (append (map-registers map) registers)))
+
+(define-integrable (map-registers:delete map register)
+ (eqv-set-delete (map-registers map) register))
+
+(define-integrable (map-registers:replace map old new)
+ (eqv-set-substitute (map-registers map) old new))
+\f
+;;;; Map Entry
+
+;; A map entry has four parts:
+;; HOME is either a pseudo-register (which has a physical address in
+;; memory associated with it) or #F indicating that the value
+;; can be flushed when the last alias is reused
+;; SAVED-INTO-HOME? is a boolean that tells whether the value in the
+;; live register can be dropped rather than pushed to the home
+;; if the last live register is needed for other purposes.
+;; NOTE: in lapgn2.scm, for the preserving code, it contains a
+;; non-boolean value (the remembered alias for a preserved
+;; value).
+;; ALIASES is a list of machine registers that contain the quantity
+;; being mapped (pseudo-register, cached value, etc.)
+;; LABEL is a tag to associate with the computed contents of the live
+;; registers holding this value. This allows individual back
+;; ends to remember labels or other hard-to-generate constant
+;; values and avoid regenerating them.
+
+(define-integrable (make-map-entry home saved-into-home? aliases label)
+ ;; HOME may be false, indicating that this is a temporary register.
+ ;; SAVED-INTO-HOME? must be true when HOME is false.
+ ;;(if (null? aliases)
+ ;; (internal-error "Empty aliases list" aliases))
+ (vector home saved-into-home? aliases label))
+
+(define-integrable (map-entry-home entry)
+ (vector-ref entry 0))
+
+(define-integrable (map-entry-saved-into-home? entry)
+ (vector-ref entry 1))
+
+(define-integrable (map-entry-aliases entry)
+ (vector-ref entry 2))
+
+(define-integrable (map-entry-label entry)
+ (vector-ref entry 3))
+
+(define-integrable (map-entry:any-alias entry)
+ (car (map-entry-aliases entry)))
+
+(define-integrable (map-entry:multiple-aliases? entry)
+ (and (not (null? (map-entry-aliases entry)))
+ (not (null? (cdr (map-entry-aliases entry))))))
+
+(define (map-entry:find-alias entry type needed-registers)
+ (list-search-positive (map-entry-aliases entry)
+ (lambda (alias)
+ (and (register-type? alias type)
+ (not (memv alias needed-registers))))))
+
+(define (map-entry:aliases entry type needed-registers)
+ (list-transform-positive (map-entry-aliases entry)
+ (lambda (alias)
+ (and (register-type? alias type)
+ (not (memv alias needed-registers))))))
+
+(define (map-entry:add-alias entry alias)
+ (make-map-entry (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (cons alias (map-entry-aliases entry))
+ (map-entry-label entry)))
+
+(define (map-entry:delete-alias entry alias)
+ (make-map-entry (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (eq-set-delete (map-entry-aliases entry) alias)
+ (map-entry-label entry)))
+
+(define (map-entry:replace-alias entry old new)
+ (make-map-entry (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (eq-set-substitute (map-entry-aliases entry) old new)
+ (map-entry-label entry)))
+
+(define-integrable (map-entry=? entry entry*)
+ (eqv? (map-entry-home entry) (map-entry-home entry*)))
+\f
+;;;; Map Constructors
+
+;;; These constructors are responsible for maintaining consistency
+;;; between the map entries and available registers.
+
+(define (register-map:add-home map home alias saved-into-home?)
+ (make-register-map (map-entries:add map
+ (make-map-entry home
+ saved-into-home?
+ (list alias)
+ false))
+ (map-registers:delete map alias)))
+
+(define (register-map:add-alias map entry alias)
+ (make-register-map
+ (map-entries:replace&touch map
+ entry
+ (map-entry:add-alias entry alias))
+ (map-registers:delete map alias)))
+
+(define (register-map:replace-alias map entry old new)
+ (make-register-map
+ (map-entries:replace&touch map
+ entry
+ (map-entry:replace-alias entry old new))
+ (map-registers:delete map new)))
+
+(define (register-map:save-entry map entry)
+ (make-register-map
+ (map-entries:replace&touch map
+ entry
+ (make-map-entry (map-entry-home entry)
+ true
+ (map-entry-aliases entry)
+ (map-entry-label entry)))
+ (map-registers map)))
+
+(define-integrable (pseudo-register-entry->temporary-entry entry)
+ (make-map-entry false
+ true
+ (map-entry-aliases entry)
+ (map-entry-label entry)))
+
+(define (register-map:entry->temporary map entry)
+ (make-register-map
+ (map-entries:replace&touch map
+ entry
+ (pseudo-register-entry->temporary-entry entry))
+ (map-registers map)))
+
+(define (register-map:delete-entry map entry)
+ (make-register-map (map-entries:delete map entry)
+ (map-registers:add* map (map-entry-aliases entry))))
+
+(define (register-map:delete-entries regmap entries)
+ (if (null? entries)
+ regmap
+ (make-register-map (map-entries:delete* regmap entries)
+ (map-registers:add* regmap
+ (append-map map-entry-aliases
+ entries)))))
+\f
+(define (register-map:delete-alias map entry alias)
+ (make-register-map (if (not (map-entry:multiple-aliases? entry))
+ (map-entries:delete map entry)
+ (map-entries:replace map
+ entry
+ (map-entry:delete-alias entry
+ alias)))
+ (map-registers:add map alias)))
+
+(define (register-map:delete-other-aliases map entry alias)
+ (make-register-map
+ (map-entries:replace map
+ entry
+ (let ((home (map-entry-home entry)))
+ (make-map-entry home
+ (not home)
+ (list alias)
+ (map-entry-label entry))))
+ (map-registers:add* map
+ ;; **** Kludge -- again, EQ? is
+ ;; assumed to work on machine regs.
+ (delq alias
+ (map-entry-aliases entry)))))
+
+(define (register-map:entries->temporaries regmap entries)
+ (if (null? entries)
+ regmap
+ (make-register-map
+ (map* (map-entries:delete* regmap entries)
+ pseudo-register-entry->temporary-entry
+ entries)
+ (map-registers regmap))))
+
+(define (register-map:keep-live-entries map live-registers)
+ (let loop
+ ((entries (map-entries map))
+ (registers (map-registers map))
+ (entries* '()))
+ (cond ((null? entries)
+ (make-register-map (reverse! entries*)
+ (sort-machine-registers registers)))
+ ((let ((home (map-entry-home (car entries))))
+ (and home
+ (regset-member? live-registers home)))
+ (loop (cdr entries)
+ registers
+ (cons (car entries) entries*)))
+ (else
+ (loop (cdr entries)
+ (append (map-entry-aliases (car entries)) registers)
+ entries*)))))
+
+(define (register-map:without-labels regmap)
+ (register-map:delete-entries
+ regmap
+ (list-transform-positive (map-entries regmap)
+ map-entry-label)))
+\f
+(define (map-equal? x y)
+ (let loop
+ ((x-entries (map-entries x))
+ (y-entries (list-transform-positive (map-entries y) map-entry-home)))
+ (cond ((null? x-entries)
+ (null? y-entries))
+ ((not (map-entry-home (car x-entries)))
+ (loop (cdr x-entries) y-entries))
+ (else
+ (and (not (null? y-entries))
+ (let ((y-entry
+ (list-search-positive y-entries
+ (let ((home (map-entry-home (car x-entries))))
+ (lambda (entry)
+ (eqv? (map-entry-home entry) home))))))
+ (and y-entry
+ (boolean=? (map-entry-saved-into-home? (car x-entries))
+ (map-entry-saved-into-home? y-entry))
+ (eqv-set-same-set? (map-entry-aliases (car x-entries))
+ (map-entry-aliases y-entry))
+ (loop (cdr x-entries) (delq! y-entry y-entries)))))))))
+\f
+;;;; Register Allocator
+
+(define (make-free-register map type needed-registers)
+ (or
+ ;; First attempt to find a register that can be used without saving
+ ;; its value.
+ (find-free-register map type needed-registers)
+ ;; Then try to recycle a register by saving its value elsewhere.
+ (map-entries:search map
+ (lambda (entry)
+ (and
+ (map-entry-home entry)
+ (not (map-entry-saved-into-home? entry))
+ (let ((alias (map-entry:find-alias entry type needed-registers)))
+ (and alias
+ (or
+ ;; If we are reallocating a register of a specific type, first
+ ;; see if there is an available register of some other
+ ;; assignment-compatible type that we can stash the value in.
+ (and type
+ (let ((values
+ (find-free-register
+ map
+ (if (register-types-compatible? type false)
+ false
+ type)
+ (cons alias needed-registers))))
+ (and
+ values
+ (bind-allocator-values values
+ (lambda (alias* map instructions)
+ (allocator-values
+ alias
+ (register-map:replace-alias map
+ entry
+ alias
+ alias*)
+ (LAP ,@instructions
+ ,@(register->register-transfer alias
+ alias*))))))))
+ ;; There is no other register that we can use, so we
+ ;; must save the value out into the home.
+ (allocator-values alias
+ (register-map:delete-alias map entry alias)
+ (save-into-home-instruction entry))))))))
+ ;; Finally, see if there is a temporary label register that can be
+ ;; recycled. Label registers are considered after ordinary
+ ;; registers, because on the RISC machines that use them, it is
+ ;; more expensive to generate a new label register than it is to
+ ;; save an ordinary register.
+ (map-entries:search map
+ (lambda (entry)
+ (and (map-entry-label entry)
+ (not (map-entry-home entry))
+ (let ((alias (map-entry:find-alias entry type needed-registers)))
+ (and alias
+ (allocator-values
+ alias
+ (register-map:delete-alias map entry alias)
+ (LAP)))))))
+ (error "MAKE-FREE-REGISTER: Unable to allocate register")))
+\f
+(define (find-free-register map type needed-registers)
+ (define (reallocate-alias entry)
+ (let ((alias (map-entry:find-alias entry type needed-registers)))
+ (and alias
+ (allocator-values alias
+ (register-map:delete-alias map entry alias)
+ '()))))
+ ;; First see if there is an unused register of the given type.
+ (or (let ((register
+ (list-search-positive (map-registers map)
+ (lambda (alias)
+ (and (register-type? alias type)
+ (not (memv alias needed-registers)))))))
+ (and register (allocator-values register map '())))
+ ;; There are no free registers available, so must reallocate
+ ;; one. First look for a temporary register that is no longer
+ ;; needed.
+ (map-entries:search map
+ (lambda (entry)
+ (and (not (map-entry-home entry))
+ (not (map-entry-label entry))
+ (reallocate-alias entry))))
+ ;; Then look for a register that contains the same thing as
+ ;; another register.
+ (map-entries:search map
+ (lambda (entry)
+ (and (map-entry:multiple-aliases? entry)
+ (reallocate-alias entry))))
+ ;; Look for a non-temporary that has been saved into its home.
+ (map-entries:search map
+ (lambda (entry)
+ (and (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (reallocate-alias entry))))))
+
+(define (allocate-register-without-spill? map type needed-registers)
+ ;; True iff a register of `type' can be allocated without saving any
+ ;; registers into their homes.
+ (or (free-register-exists? map type needed-registers)
+ (map-entries:search map
+ (lambda (entry)
+ (let ((alias (map-entry:find-alias entry type needed-registers)))
+ (and alias
+ (free-register-exists?
+ map
+ (if (register-types-compatible? type false) false type)
+ (cons alias needed-registers))))))))
+
+(define (free-register-exists? map type needed-registers)
+ ;; True iff a register of `type' can be allocated without first
+ ;; saving its contents.
+ (or (allocate-register-without-unload? map type needed-registers)
+ (map-entries:search map
+ (lambda (entry)
+ (and (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (map-entry:find-alias entry type needed-registers))))))
+
+(define (allocate-register-without-unload? map type needed-registers)
+ ;; True iff a register of `type' can be allocated without displacing
+ ;; any pseudo-registers from the register map.
+ (or (list-search-positive (map-registers map)
+ (lambda (alias)
+ (and (register-type? alias type)
+ (not (memv alias needed-registers)))))
+ (map-entries:search map
+ (lambda (entry)
+ (and (map-entry:find-alias entry type needed-registers)
+ (or (not (map-entry-home entry))
+ (map-entry:multiple-aliases? entry)))))))
+\f
+;;;; Allocator Operations
+
+(define (load-alias-register map type needed-registers home)
+ ;; Finds or makes an alias register for HOME, and loads HOME's
+ ;; contents into that register.
+ (or (let ((entry (map-entries:find-home map home)))
+ (and entry
+ (let ((alias (list-search-positive (map-entry-aliases entry)
+ (register-type-predicate type))))
+ (and alias
+ (allocator-values alias map '())))))
+ (bind-allocator-values (make-free-register map type needed-registers)
+ (lambda (alias map instructions)
+ (let ((entry (map-entries:find-home map home)))
+ (if entry
+ (allocator-values
+ alias
+ (register-map:add-alias map entry alias)
+ (LAP ,@instructions
+ ,@(if (null? (map-entry-aliases entry))
+ (home->register-transfer home alias)
+ (register->register-transfer
+ (map-entry:any-alias entry)
+ alias))))
+ (allocator-values
+ alias
+ (register-map:add-home map home alias true)
+ (LAP ,@instructions
+ ,@(home->register-transfer home alias)))))))))
+
+(define (allocate-alias-register map type needed-registers home)
+ ;; Makes an alias register for `home'. Used when about to modify
+ ;; `home's contents. It is assumed that no entry exists for `home'.
+ (bind-allocator-values (make-free-register map type needed-registers)
+ (lambda (alias map instructions)
+ (allocator-values alias
+ (register-map:add-home map home alias false)
+ instructions))))
+
+(define (allocate-temporary-register map type needed-registers)
+ (bind-allocator-values (make-free-register map type needed-registers)
+ (lambda (alias map instructions)
+ (allocator-values alias
+ (register-map:add-home map false alias true)
+ instructions))))
+
+(define (add-pseudo-register-alias map register alias saved-into-home?)
+ (let ((map (delete-machine-register map alias)))
+ (let ((entry (map-entries:find-home map register)))
+ (if entry
+ (register-map:add-alias map entry alias)
+ (register-map:add-home map register alias saved-into-home?)))))
+
+(define (machine-register-contents map register)
+ (let ((entry (map-entries:find-alias map register)))
+ (and entry
+ (map-entry-home entry))))
+
+(define (pseudo-register-aliases map register)
+ (let ((entry (map-entries:find-home map register)))
+ (and entry
+ (let ((aliases (map-entry-aliases entry)))
+ (and (not (null? aliases))
+ aliases)))))
+\f
+(define (machine-register-alias map type register)
+ "Returns another machine register, of the given TYPE, which holds
+the same value as REGISTER. If no such register exists, returns #F."
+ (let ((entry (map-entries:find-alias map register)))
+ (and entry
+ (list-search-positive (map-entry-aliases entry)
+ (lambda (register*)
+ (and (not (eq? register register*))
+ (register-type? type register*)))))))
+
+(define (pseudo-register-alias map type register)
+ "Returns a machine register, of the given TYPE, which is an alias
+for REGISTER. If no such register exists, returns #F."
+ (let ((entry (map-entries:find-home map register)))
+ (and entry
+ (list-search-positive (map-entry-aliases entry)
+ (register-type-predicate type)))))
+
+(define (machine-register-is-unique? map register)
+ "True if REGISTER has no other aliases."
+ (let ((entry (map-entries:find-alias map register)))
+ (or (not entry)
+ (not (map-entry:multiple-aliases? entry)))))
+
+(define (machine-register-holds-unique-value? map register)
+ "True if the contents of REGISTER is not saved anywhere else."
+ (let ((entry (map-entries:find-alias map register)))
+ (or (not entry)
+ (and (not (map-entry:multiple-aliases? entry))
+ (not (map-entry-saved-into-home? entry))))))
+
+(define (is-pseudo-register-alias? map maybe-alias register)
+ (let ((entry (map-entries:find-home map register)))
+ (and entry
+ (list-search-positive (map-entry-aliases entry)
+ (lambda (alias)
+ (eqv? maybe-alias alias))))))
+
+(define (save-machine-register map register receiver)
+ (let ((entry (map-entries:find-alias map register)))
+ (if (or (not entry)
+ (map-entry-saved-into-home? entry)
+ (map-entry:multiple-aliases? entry))
+ (receiver map '())
+ (receiver (register-map:save-entry map entry)
+ (save-into-home-instruction entry)))))
+
+(define (save-pseudo-register map register receiver)
+ (let ((entry (map-entries:find-home map register)))
+ (if (and entry
+ (not (map-entry-saved-into-home? entry)))
+ (receiver (register-map:save-entry map entry)
+ (save-into-home-instruction entry))
+ (receiver map '()))))
+\f
+;; Like save-machine-register, but saves into another machine register,
+;; avoiding avoidregs. Only does so if there are enough temporaries left
+;; after the assignment.
+
+(define *min-number-of-temps* 1)
+
+(define (preserve-machine-register map register avoidregs receiver)
+ (let ((entry (map-entries:find-alias map register)))
+ (if (or (not entry)
+ (map-entry-saved-into-home? entry)
+ (map-entry:multiple-aliases? entry))
+ (receiver map '())
+ (let* ((available
+ (list-transform-positive
+ (eq-set-difference (map-registers map) avoidregs)
+ (let ((type (register-type register)))
+ (lambda (register*)
+ (register-type? register* type)))))
+ (navailable (length available)))
+ (if (<= navailable *min-number-of-temps*)
+ (receiver (register-map:save-entry map entry)
+ (save-into-home-instruction entry))
+ (let ((register* (car (sort-machine-registers available))))
+ (receiver
+ (register-map:add-alias map entry register*)
+ (register->register-transfer register register*))))))))
+
+(define (register-map-label map type)
+ (let loop ((entries (map-entries map)))
+ (if (null? entries)
+ (values false false)
+ (let ((alias
+ (and (map-entry-label (car entries))
+ (map-entry:find-alias (car entries) type '()))))
+ (if alias
+ (values (map-entry-label (car entries)) alias)
+ (loop (cdr entries)))))))
+
+(define (register-map-labels map type)
+ (let loop ((entries (map-entries map)))
+ (if (null? entries)
+ '()
+ (let ((label (map-entry-label (car entries))))
+ (if label
+ (let ((aliases (map-entry:aliases (car entries) type '())))
+ (if (not (null? aliases))
+ (cons (cons label aliases)
+ (loop (cdr entries)))
+ (loop (cdr entries))))
+ (loop (cdr entries)))))))
+
+(define (set-machine-register-label map register label)
+ (let ((entry (map-entries:find-alias map register)))
+ (if entry
+ (make-register-map (map-entries:replace
+ map
+ entry
+ (make-map-entry (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (map-entry-aliases entry)
+ label))
+ (map-registers map))
+ (make-register-map (map-entries:add map
+ (make-map-entry false
+ true
+ (list register)
+ label))
+ (map-registers:delete map register)))))
+\f
+(define (pseudo-register-saved-into-home? map register)
+ (let ((entry (map-entries:find-home map register)))
+ (or (not entry)
+ (map-entry-saved-into-home? entry))))
+#|
+(define (pseudo-register-saved-into-home? map register)
+ (let ((entry (map-entries:find-home map register)))
+ (or (not entry)
+ (let ((saved? (map-entry-saved-into-home? entry)))
+ (if (boolean? saved?)
+ saved?
+ (bkpt 'oops-pseduo-reg))))))
+|#
+
+(define (delete-machine-register map register)
+ (let ((entry (map-entries:find-alias map register)))
+ (if entry
+ (register-map:delete-alias map entry register)
+ map)))
+
+(define (lock-machine-register map register)
+ (make-register-map (map-entries map)
+ (map-registers:delete map register)))
+
+(define (release-machine-register map register)
+ (if (map-entries:find-alias map register)
+ map
+ (make-register-map (map-entries map)
+ (map-registers:add map register))))
+
+(define (delete-pseudo-register map register receiver)
+ ;; If the pseudo-register has any alias with a cached value --
+ ;; indicated by a labelled entry -- then we convert the map entry to
+ ;; represent a temporary register rather than a pseudo register.
+ ;;
+ ;; receiver gets the new map and the aliases that are no longer
+ ;; needed (even if it is convenient to keep them around)
+ (let ((entry (map-entries:find-home map register)))
+ (cond ((not entry) (receiver map '()))
+ ((not (map-entry-label entry))
+ (receiver (register-map:delete-entry map entry)
+ (map-entry-aliases entry)))
+ (else ; Pseudo -> temporary
+ (receiver (register-map:entry->temporary map entry)
+ (map-entry-aliases entry))))))
+
+(define (delete-pseudo-registers map registers)
+ ;; Used to remove dead registers from the map.
+ ;; See comments to delete-pseudo-register, above.
+
+ (define (create-new-map delete transform)
+ (register-map:entries->temporaries (register-map:delete-entries map delete)
+ transform))
+
+
+ (let loop ((registers registers)
+ (entries-to-delete '())
+ (entries-to-transform '()))
+ (if (null? registers)
+ (create-new-map entries-to-delete entries-to-transform)
+ (let ((entry (map-entries:find-home map (car registers))))
+ (loop (cdr registers)
+ (if (and entry (not (map-entry-label entry)))
+ (cons entry entries-to-delete)
+ entries-to-delete)
+ (if (and entry (map-entry-label entry))
+ (cons entry entries-to-transform)
+ entries-to-transform))))))
+
+(define (delete-other-locations map register)
+ ;; Used in assignments to indicate that other locations containing
+ ;; the same value no longer contain the value for a given home.
+ (register-map:delete-other-aliases
+ map
+ (or (map-entries:find-alias map register)
+ (error "DELETE-OTHER-LOCATIONS: Missing entry" register))
+ register))
+
+(define-integrable (allocator-values alias map instructions)
+ (vector alias map instructions))
+
+(define (bind-allocator-values values receiver)
+ (receiver (vector-ref values 0)
+ (vector-ref values 1)
+ (vector-ref values 2)))
+
+(define (save-into-home-instruction entry)
+ (register->home-transfer (map-entry:any-alias entry)
+ (map-entry-home entry)))
+
+(define (register-map-live-homes map)
+ (let loop ((entries (map-entries map)))
+ (if (null? entries)
+ '()
+ (let ((home (map-entry-home (car entries))))
+ (if home
+ (cons home (loop (cdr entries)))
+ (loop (cdr entries)))))))
+
+(define (register-map-clear? map)
+ (for-all? (map-entries map) map-entry-saved-into-home?))
+\f
+;;;; Map Coercion
+
+;;; These operations generate the instructions to coerce one map into
+;;; another. They are used when joining two branches of a control
+;;; flow graph that have different maps (e.g. in a loop.)
+
+(package (coerce-map-instructions clear-map-instructions)
+
+(define-export (coerce-map-instructions input-map output-map)
+ (three-way-sort
+ map-entry=?
+ (list-transform-negative (map-entries input-map)
+ (lambda (entry)
+ (null? (map-entry-aliases entry))))
+ (list-transform-negative (map-entries output-map)
+ (lambda (entry)
+ (null? (map-entry-aliases entry))))
+ (lambda (input-entries shared-entries output-entries)
+ #|
+ (input-loop input-entries
+ (shared-loop shared-entries
+ (output-loop output-entries)))
+ |#
+ (LAP ,@(input-loop input-entries (LAP))
+ ,@(fluid-let ((*register-map* input-map))
+ (register-set-assign
+ (map (lambda (entry)
+ (map-entry-aliases (car entry)))
+ shared-entries)
+ (map (lambda (entry)
+ (map-entry-aliases (cdr entry)))
+ shared-entries)))
+ ,@(output-loop output-entries)))))
+
+(define-export (clear-map-instructions input-map)
+ input-map
+ (input-loop (map-entries input-map) (LAP)))
+
+(define (input-loop entries tail)
+ (let loop ((entries entries))
+ (cond ((null? entries)
+ tail)
+ ((map-entry-saved-into-home? (car entries))
+ (loop (cdr entries)))
+ (else
+ (LAP ,@(save-into-home-instruction (car entries))
+ ,@(loop (cdr entries)))))))
+
+#|
+;; This is severely broken. It does not do parallel assignments,
+;; so it may overwrite something that it needs.
+
+(define (shared-loop entries tail)
+ (let entries-loop ((entries entries))
+ (if (null? entries)
+ tail
+ (let ((input-aliases (map-entry-aliases (caar entries))))
+ (let aliases-loop
+ ((output-aliases
+ (eqv-set-difference (map-entry-aliases (cdar entries))
+ input-aliases)))
+ (if (null? output-aliases)
+ (entries-loop (cdr entries))
+ (LAP ,@(register->register-transfer (car input-aliases)
+ (car output-aliases))
+ ,@(aliases-loop (cdr output-aliases)))))))))
+|#
+
+(define (output-loop entries)
+ (if (null? entries)
+ '()
+ (let ((home (map-entry-home (car entries))))
+ (if home
+ (let ((aliases (map-entry-aliases (car entries))))
+ (if (null? aliases)
+ (output-loop (cdr entries))
+ (LAP ,@(home->register-transfer home (car aliases))
+ ,@(let registers-loop ((registers (cdr aliases)))
+ (if (null? registers)
+ (output-loop (cdr entries))
+ (LAP ,@(register->register-transfer
+ (car aliases)
+ (car registers))
+ ,@(registers-loop (cdr registers))))))))
+ (output-loop (cdr entries))))))
+
+)
+\f
+;; This depends heavily on the registers being fixnums!
+
+(define (register-set-assign sets sets*)
+ ;; Each element of set is a list of registers.
+ ;; Each register belongs to at most one of the sets in each
+ ;; of sets and sets*
+ ;; Each of the elements of sets (sets*) defines an equivalence class
+ ;; of registers containing the same value. The purpose of this
+ ;; procedure is to make the contents of each equivalence class in sets*
+ ;; be the contents of the corresponding equivalence class in sets
+ ;; Typically (except on 68k!) each equivalence class consists of exactly
+ ;; one register, so that case is handled specially
+ (if (and (for-all? sets singleton?)
+ (for-all? sets* singleton?))
+ (call-with-values
+ (lambda ()
+ (singleton-register-set-assign sets sets*))
+ (lambda (instrs needed clobbered)
+ needed clobbered ; ignored
+ instrs))
+ ;; This is pretty poor, but...
+ (call-with-values
+ (lambda ()
+ (choose-representatives sets sets*))
+ (lambda (sets1 sets*1)
+ (call-with-values
+ (lambda ()
+ (singleton-register-set-assign sets1 sets*1))
+ (lambda (instrs needed clobbered)
+ needed ; ignored
+ (let outer ((instrs instrs)
+ (sets* sets*)
+ (sets*1 sets*1)
+ (sets sets))
+ (cond ((null? sets*)
+ instrs)
+ ((null? (cdr sets*))
+ (outer instrs (cdr sets*) (cdr sets*1) (cdr sets)))
+ (else
+ (let ((rep (caar sets*1)))
+ (let inner
+ ((instrs instrs)
+ (to-fill
+ (let ((intersection
+ (eq-set-intersection (car sets*)
+ (car sets))))
+ (list-transform-negative (car sets*)
+ (lambda (reg)
+ (or (eq? reg rep)
+ (and (memq reg intersection)
+ (not (memq reg clobbered)))))))))
+ (if (null? to-fill)
+ (outer instrs
+ (cdr sets*)
+ (cdr sets*1)
+ (cdr sets))
+ (inner
+ (LAP ,@instrs
+ ,@(register->register-transfer
+ rep
+ (car to-fill)))
+ (cdr to-fill))))))))))))))
+\f
+(define (singleton? set)
+ (and (not (null? set))
+ (null? (cdr set))))
+
+(define (choose-free-register avoid)
+ (list-search-negative available-machine-registers
+ (lambda (reg)
+ (memq reg avoid))))
+
+(define (choose-representatives sets sets*)
+ (if (null? sets)
+ (values '() '())
+ (call-with-values
+ (lambda ()
+ (choose-representatives (cdr sets) (cdr sets*)))
+ (lambda (reps reps*)
+ (let ((set (car sets))
+ (set* (car sets*)))
+ (let ((intersection (eq-set-intersection set set*)))
+ (if (null? intersection)
+ (values (cons (list (car set)) reps)
+ (cons (list (car set*)) reps*))
+ (values (cons (list (car intersection)) reps)
+ (cons (list (car intersection)) reps*)))))))))
+
+(define (singleton-register-set-assign sets sets*)
+ (let ((need-work
+ (list-transform-negative (map (lambda (set set*)
+ (list (car set*) (car set)))
+ sets sets*)
+ (lambda (pair)
+ (eq? (car pair) (cadr pair))))))
+ (if (null? need-work)
+ (values (LAP) (map car sets) '())
+ ;; This is trying to be clever, because only one temp
+ ;; is needed
+ (singleton-register-set-assign-finish
+ (map car sets)
+ (parallel-assignment need-work)))))
+
+;; Used only when there aren't enough physical registers
+
+(define (restore-from-home dst)
+ (home->register-transfer (machine-register-contents *register-map* dst)
+ dst))
+
+(define (store-in-home src dst)
+ (register->home-transfer src
+ (machine-register-contents *register-map* dst)))
+\f
+(define (singleton-register-set-assign-finish inuse parresult)
+ (let loop ((result parresult)
+ (regsinuse inuse)
+ (regswritten '())
+ (instrs (LAP))
+ (pending '()))
+ (cond ((and (not (null? pending))
+ (there-exists? pending
+ (lambda (pair)
+ (and (not (memq (car pair) regsinuse))
+ pair))))
+ => (lambda (pair)
+ (let ((src (cadr pair))
+ (dst (car pair)))
+ (if (eq? src '*HOME*)
+ (loop result
+ (eq-set-adjoin dst regsinuse)
+ (eq-set-adjoin dst regswritten)
+ (LAP ,@instrs
+ ,@(restore-from-home dst))
+ (delq pair pending))
+ (loop result
+ (eq-set-adjoin dst
+ (eq-set-delete regsinuse src))
+ (eq-set-adjoin dst regswritten)
+ (LAP ,@instrs
+ ,@(register->register-transfer src dst))
+ (delq pair pending))))))
+ ((not (null? result))
+ (let* ((next (car result))
+ (dependency (vector-ref next 1))
+ (last-refs (vector-ref next 2))
+ (inuse* (eq-set-difference regsinuse last-refs))
+ (src (cadr dependency))
+ (dst (car dependency)))
+ (if (not (vector-ref next 0))
+ ;; Can do assignment now
+ (loop (cdr result)
+ (eq-set-adjoin dst inuse*)
+ (eq-set-adjoin dst regswritten)
+ (LAP ,@instrs
+ ,@(register->register-transfer src dst))
+ pending)
+ (begin
+ (if (not (null? pending))
+ (warn "More than one temp for singleton assignment?"
+ parresult))
+ (let ((temp (choose-free-register regsinuse)))
+ (if (not temp)
+ (loop (cdr result)
+ inuse*
+ regswritten
+ (LAP ,@instrs
+ ,@(store-in-home src dst))
+ (cons (list dst '*HOME*) pending))
+ (loop (cdr result)
+ (eq-set-adjoin temp inuse*)
+ (eq-set-adjoin temp regswritten)
+ (LAP ,@instrs
+ ,@(register->register-transfer src temp))
+ (cons (list dst temp) pending))))))))
+ (else
+ (values instrs regsinuse regswritten)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: syerly.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1988-1993 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. |#
+
+;;;; Syntax time instruction expansion
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Early instruction assembly
+
+(define lap:syntax-instruction-expander
+ (scode->scode-expander
+ (lambda (operands if-expanded if-not-expanded)
+ (let ((instruction (scode/unquasiquote (car operands))))
+ (let ((ierror
+ (lambda (message)
+ (error (string-append "LAP:SYNTAX-INSTRUCTION-EXPANDER: "
+ message)
+ instruction))))
+ (if (not (pair? instruction))
+ (ierror "bad instruction"))
+ (cond ((eq? (car instruction) 'UNQUOTE)
+ (if-not-expanded))
+ ((memq (car instruction)
+ '(EQUATE SCHEME-OBJECT SCHEME-EVALUATION
+ ENTRY-POINT LABEL BLOCK-OFFSET))
+ (if-expanded
+ (scode/make-combination
+ (scode/make-variable 'DIRECTIVE->INSTRUCTION-SEQUENCE)
+ operands)))
+ (else
+ (let ((place (assq (car instruction) early-instructions)))
+ (if (not place)
+ (ierror "unknown opcode"))
+ (let ((opcode (car instruction))
+ (body (cdr instruction))
+ (rules (cdr place)))
+ (early-pattern-lookup
+ rules
+ body
+ early-transformers
+ (scode/make-constant opcode)
+ (lambda (mode result)
+ (if (false? mode)
+ (ierror "unknown instruction"))
+ (if (eq? mode 'TOO-MANY)
+ (if-not-expanded)
+ (if-expanded result)))
+ 1))))))))))
+\f
+;;;; Quasiquote unsyntaxing
+
+(define (scode/unquasiquote exp)
+ (cond ((scode/combination? exp)
+ (scode/combination-components
+ exp
+ (lambda (operator operands)
+ (define (kernel operator-name)
+ (case operator-name
+ ((CONS)
+ (cons (scode/unquasiquote (car operands))
+ (scode/unquasiquote (cadr operands))))
+ ((LIST)
+ (apply list (map scode/unquasiquote operands)))
+ ((CONS*)
+ (apply cons* (map scode/unquasiquote operands)))
+ ((APPEND)
+ (append-map (lambda (component)
+ (if (scode/constant? component)
+ (scode/constant-value component)
+ (list (list 'UNQUOTE-SPLICING component))))
+ operands))
+ (else (list 'UNQUOTE exp))))
+ (cond ((eq? operator cons)
+ ;; integrations
+ (kernel 'CONS))
+ ((scode/absolute-reference? operator)
+ (kernel (scode/absolute-reference-name operator)))
+ (else (list 'UNQUOTE exp))))))
+ ((scode/constant? exp)
+ (scode/constant-value exp))
+ (else (list 'UNQUOTE exp))))
+\f
+;;;; Bit compression expanders
+
+;;; SYNTAX-EVALUATION and OPTIMIZE-GROUP expanders
+
+(define syntax-evaluation-expander
+ (scode->scode-expander
+ (let ((environment
+ (package/environment (find-package '(COMPILER LAP-SYNTAXER)))))
+ (lambda (operands if-expanded if-not-expanded)
+ (if (and (scode/constant? (car operands))
+ (scode/variable? (cadr operands))
+ (not (lexical-unreferenceable?
+ environment
+ (scode/variable-name (cadr operands)))))
+ (if-expanded
+ (scode/make-constant
+ ((lexical-reference environment
+ (scode/variable-name (cadr operands)))
+ (scode/constant-value (car operands)))))
+ (if-not-expanded))))))
+
+;; This relies on the fact that scode/constant-value = identity-procedure.
+
+(define optimize-group-expander
+ (scode->scode-expander
+ (lambda (operands if-expanded if-not-expanded)
+ if-not-expanded
+ (optimize-group-internal
+ operands
+ (lambda (result make-group?)
+ (if make-group?
+ (if-expanded
+ (scode/make-combination (scode/make-variable 'OPTIMIZE-GROUP)
+ result))
+ (if-expanded
+ (scode/make-constant result))))))))
+\f
+;;;; CONS-SYNTAX expander
+
+(define (is-operator? expr name primitive)
+ (or (and primitive
+ (scode/constant? expr)
+ (eq? (scode/constant-value expr) primitive))
+ (and (scode/variable? expr)
+ (eq? (scode/variable-name expr) name))
+ (and (scode/absolute-reference? expr)
+ (eq? (scode/absolute-reference-name expr) name))))
+
+(define cons-syntax-expander
+ (scode->scode-expander
+ (lambda (operands if-expanded if-not-expanded)
+ (let ((default
+ (lambda ()
+ (if (not (scode/constant? (cadr operands)))
+ (if-not-expanded)
+ (begin
+ (if (not (null? (scode/constant-value (cadr operands))))
+ (error "CONS-SYNTAX-EXPANDER: bad tail"
+ (cadr operands)))
+ (if-expanded (scode/make-combination cons operands)))))))
+ (if (and (scode/constant? (car operands))
+ (bit-string? (scode/constant-value (car operands)))
+ (scode/combination? (cadr operands)))
+ (scode/combination-components (cadr operands)
+ (lambda (operator inner-operands)
+ (if (and (or (is-operator? operator 'CONS-SYNTAX false)
+ (is-operator? operator 'CONS cons))
+ (scode/constant? (car inner-operands))
+ (bit-string?
+ (scode/constant-value (car inner-operands))))
+ (if-expanded
+ (scode/make-combination
+ (if (scode/constant? (cadr inner-operands))
+ cons
+ operator)
+ (cons (instruction-append
+ (scode/constant-value (car operands))
+ (scode/constant-value (car inner-operands)))
+ (cdr inner-operands))))
+ (default))))
+ (default))))))
+\f
+;;;; INSTRUCTION->INSTRUCTION-SEQUENCE expander
+
+(define instruction->instruction-sequence-expander
+ (let ()
+ (define (parse expression receiver)
+ (if (not (scode/combination? expression))
+ (receiver false false false)
+ (scode/combination-components expression
+ (lambda (operator operands)
+ (cond ((and (not (is-operator? operator 'CONS cons))
+ (not (is-operator? operator 'CONS-SYNTAX false)))
+ (receiver false false false))
+ ((scode/constant? (cadr operands))
+ (if (not (null? (scode/constant-value (cadr operands))))
+ (error "INST->INST-SEQ-EXPANDER: bad CONS-SYNTAX tail"
+ (scode/constant-value (cadr operands))))
+ (let ((name
+ (generate-uninterned-symbol 'INSTRUCTION-TAIL-)))
+ (receiver true
+ (cons name expression)
+ (scode/make-variable name))))
+ (else
+ (parse (cadr operands)
+ (lambda (mode info rest)
+ (if (not mode)
+ (receiver false false false)
+ (receiver true info
+ (scode/make-combination
+ operator
+ (list (car operands) rest))))))))))))
+ (scode->scode-expander
+ (lambda (operands if-expanded if-not-expanded)
+ (if (not (scode/combination? (car operands)))
+ (if-not-expanded)
+ (parse (car operands)
+ (lambda (mode binding rest)
+ (if (not mode)
+ (if-not-expanded)
+ (if-expanded
+ (scode/make-let
+ (list (car binding))
+ (list (cdr binding))
+ (scode/make-combination
+ cons
+ (list rest
+ (scode/make-variable (car binding))))))))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: symtab.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1987-1993 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. |#
+
+;;;; Symbol Tables
+;;; package: (compiler assembler)
+
+(declare (usual-integrations))
+\f
+(define make-symbol-table
+ (strong-hash-table/constructor eq-hash-mod eq? #t))
+
+(define (symbol-table-define! table key value)
+ (let ((binding (hash-table/get table key #f)))
+ (if binding
+ (begin
+ (error "Redefining symbol:" key)
+ (set-binding-value! binding value))
+ (hash-table/put! table key (make-binding value)))))
+
+(define (symbol-table-value table key)
+ (let ((binding (hash-table/get table key #f)))
+ (if (not binding)
+ (error "Undefined key:" key))
+ (let ((value (binding-value binding)))
+ (if (not value)
+ (error "Key has no value:" key))
+ value)))
+
+(define (symbol-table->assq-list table)
+ (map (lambda (pair)
+ (cons (car pair) (binding-value (cdr pair))))
+ (symbol-table-bindings table)))
+
+(define-integrable (symbol-table-bindings table)
+ (hash-table->alist table))
+
+(define-integrable (make-binding initial-value)
+ (cons initial-value '()))
+
+(define-integrable (binding-value binding)
+ (car binding))
+
+(define (set-binding-value! binding value)
+ (set-car! binding value))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: syntax.scm,v 1.1 1994/11/19 01:54:17 adams Exp $
+
+Copyright (c) 1988-1993 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. |#
+
+;;;; LAP Syntaxer
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define-integrable cons-syntax cons)
+(define-integrable append-syntax! append!)
+
+#|
+(define (cons-syntax directive directives)
+ (if (and (bit-string? directive)
+ (not (null? directives))
+ (bit-string? (car directives)))
+ (begin (set-car! directives
+ (instruction-append directive (car directives)))
+ directives)
+ (cons directive directives)))
+
+(define (append-syntax! directives1 directives2)
+ (cond ((null? directives1) directives2)
+ ((null? directives2) directives1)
+ (else
+ (let ((tail (last-pair directives1)))
+ (if (and (bit-string? (car tail))
+ (bit-string? (car directives2)))
+ (begin
+ (set-car! tail
+ (instruction-append (car tail) (car directives2)))
+ (set-cdr! tail (cdr directives2)))
+ (set-cdr! tail directives2))
+ directives1))))
+|#
+
+(define (lap:syntax-instruction instruction)
+ (if (memq (car instruction)
+ '(EQUATE SCHEME-OBJECT SCHEME-EVALUATION
+ ENTRY-POINT LABEL BLOCK-OFFSET
+ PADDING))
+ (list instruction)
+ (let ((match-result (instruction-lookup instruction)))
+ (if (not match-result)
+ (error "illegal instruction syntax" instruction))
+ (match-result))))
+
+(define (instruction-lookup instruction)
+ (pattern-lookup
+ (cdr (or (assq (car instruction) instructions)
+ (error "INSTRUCTION-LOOKUP: Unknown keyword" (car instruction))))
+ (cdr instruction)))
+
+(define (add-instruction! keyword lookup)
+ (let ((entry (assq keyword instructions)))
+ (if entry
+ (set-cdr! entry lookup)
+ (set! instructions (cons (cons keyword lookup) instructions))))
+ keyword)
+
+(define instructions
+ '())
+\f
+(define (integer-syntaxer expression coercion-type size)
+ (let ((name (make-coercion-name coercion-type size)))
+ (if (exact-integer? expression)
+ `',((lookup-coercion name) expression)
+ `(SYNTAX-EVALUATION ,expression ,name))))
+
+(define (syntax-evaluation expression coercion)
+ (if (exact-integer? expression)
+ (coercion expression)
+ `(EVALUATION ,expression ,(coercion-size coercion) ,coercion)))
+
+(define (optimize-group . components)
+ (optimize-group-internal components
+ (lambda (result make-group?)
+ (if make-group?
+ `(GROUP ,@result)
+ result))))
+
+(define-integrable optimize-group-early
+ optimize-group)
+
+(define optimize-group-internal
+ (let ()
+ (define (loop1 components)
+ (cond ((null? components) '())
+ ((bit-string? (car components))
+ (loop2 (car components) (cdr components)))
+ (else
+ (cons (car components)
+ (loop1 (cdr components))))))
+
+ (define (loop2 bit-string components)
+ (cond ((null? components)
+ (list bit-string))
+ ((bit-string? (car components))
+ (loop2 (instruction-append bit-string (car components))
+ (cdr components)))
+ (else
+ (cons bit-string
+ (cons (car components)
+ (loop1 (cdr components)))))))
+
+ (lambda (components receiver)
+ (let ((components (loop1 components)))
+ (if (null? components)
+ (error "OPTIMIZE-GROUP: No components"))
+ (if (null? (cdr components))
+ (receiver (car components) false)
+ (receiver components true))))))
+\f
+;;;; Variable width expression processing
+
+(define (choose-clause value clauses)
+ (if (null? clauses)
+ (error "CHOOSE-CLAUSE: value out of range" value))
+ (if (let ((low (caddr (car clauses)))
+ (high (cadddr (car clauses))))
+ (and (or (null? low)
+ (<= low value))
+ (or (null? high)
+ (<= value high))))
+ (car clauses)
+ (choose-clause value (cdr clauses))))
+
+(define (variable-width-expression-syntaxer name expression clauses)
+ (if (exact-integer? expression)
+ (let ((chosen (choose-clause expression clauses)))
+ `(LET ((,name ,expression))
+ (DECLARE (INTEGRATE ,name))
+ ,name ;ignore if not referenced
+ (CAR ,(car chosen))))
+ `(SYNTAX-VARIABLE-WIDTH-EXPRESSION
+ ,expression
+ (LIST
+ ,@(map (LAMBDA (clause)
+ `(CONS (LAMBDA (,name)
+ ,name ;ignore if not referenced
+ ,(car clause))
+ ',(cdr clause)))
+ clauses)))))
+
+(define (syntax-variable-width-expression expression clauses)
+ (if (exact-integer? expression)
+ (let ((chosen (choose-clause expression clauses)))
+ (car ((car chosen) expression)))
+ `(VARIABLE-WIDTH-EXPRESSION
+ ,expression
+ ,@clauses)))
+\f
+;;;; Coercion Machinery
+
+(define (make-coercion-name coercion-type size)
+ (intern
+ (string-append "coerce-"
+ (number->string size)
+ "-bit-"
+ (symbol->string coercion-type))))
+
+(define coercion-property-tag
+ "Coercion")
+
+(define ((coercion-maker coercion-types) coercion-type size)
+ (let ((coercion
+ ((cdr (or (assq coercion-type coercion-types)
+ (error "Unknown coercion type" coercion-type)))
+ size)))
+ (2D-put! coercion coercion-property-tag (list coercion-type size))
+ coercion))
+
+(define (coercion-size coercion)
+ (cadr (coercion-properties coercion)))
+
+(define (unmake-coercion coercion receiver)
+ (apply receiver (coercion-properties coercion)))
+
+(define (coercion-properties coercion)
+ (or (2D-get coercion coercion-property-tag)
+ (error "COERCION-PROPERTIES: Not a known coercion" coercion)))
+
+(define coercion-environment
+ (the-environment))
+
+(define-integrable (lookup-coercion name)
+ (lexical-reference coercion-environment name))
+
+(define ((coerce-unsigned-integer nbits) n)
+ (unsigned-integer->bit-string nbits n))
+
+(define (coerce-signed-integer nbits)
+ (let* ((limit (expt 2 (-1+ nbits)))
+ (offset (+ limit limit)))
+ (lambda (n)
+ (unsigned-integer->bit-string
+ nbits
+ (cond ((negative? n) (+ n offset))
+ ((< n limit) n)
+ (else (error "Integer too large to be encoded" n)))))))
+
+(define (standard-coercion kernel)
+ (lambda (nbits)
+ (lambda (n)
+ (unsigned-integer->bit-string nbits (kernel n)))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff