From: Stephen Adams Date: Sat, 19 Nov 1994 01:54:17 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~7006 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b90a6006ac393ae52956591cabd4ab924ae1431c;p=mit-scheme.git Initial revision --- diff --git a/v8/src/compiler/back/asmmac.scm b/v8/src/compiler/back/asmmac.scm new file mode 100644 index 000000000..847f18304 --- /dev/null +++ b/v8/src/compiler/back/asmmac.scm @@ -0,0 +1,122 @@ +#| -*-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)) + +(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))))))) diff --git a/v8/src/compiler/back/asutl.scm b/v8/src/compiler/back/asutl.scm new file mode 100644 index 000000000..39ab2c745 --- /dev/null +++ b/v8/src/compiler/back/asutl.scm @@ -0,0 +1,71 @@ +#| -*-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)) + +(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 diff --git a/v8/src/compiler/back/bittop.scm b/v8/src/compiler/back/bittop.scm new file mode 100644 index 000000000..256121c9d --- /dev/null +++ b/v8/src/compiler/back/bittop.scm @@ -0,0 +1,564 @@ +#| -*-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)) + +(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)) + +;;; 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)) + +(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 ) + (cdr object)) + ((SCHEME-EVALUATION) + ;; (SCHEME-EVALUATION ) + (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))) + +(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)))) + + (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*)) + +;;;; 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)) + + (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 '() '() '()))) + +(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 '() '())) + +(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 '()))) + +(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 diff --git a/v8/src/compiler/back/bitutl.scm b/v8/src/compiler/back/bitutl.scm new file mode 100644 index 000000000..2d3008160 --- /dev/null +++ b/v8/src/compiler/back/bitutl.scm @@ -0,0 +1,348 @@ +#| -*-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)) + +(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)) + +;;;; 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)))))) + +;;;; 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)) + +(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)) + +;;; 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)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 diff --git a/v8/src/compiler/back/lapgn1.scm b/v8/src/compiler/back/lapgn1.scm new file mode 100644 index 000000000..b99614e7f --- /dev/null +++ b/v8/src/compiler/back/lapgn1.scm @@ -0,0 +1,400 @@ +#| -*-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)) + +(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))))))))))))))) + +(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)))) + +(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)))))) + +(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)))))) + +(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)))))) + +(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))))) + +;;; 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 diff --git a/v8/src/compiler/back/lapgn2.scm b/v8/src/compiler/back/lapgn2.scm new file mode 100644 index 000000000..1eb98b9bc --- /dev/null +++ b/v8/src/compiler/back/lapgn2.scm @@ -0,0 +1,725 @@ +#| -*-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)) + +;; `*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*))) + +;; 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)))) + +(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)) + +(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) + +(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) + + (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))))) + +(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)))))))))) + +(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))) + +(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))))))) + +(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)))))) + +;;; 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 diff --git a/v8/src/compiler/back/lapgn3.scm b/v8/src/compiler/back/lapgn3.scm new file mode 100644 index 000000000..648cd30b7 --- /dev/null +++ b/v8/src/compiler/back/lapgn3.scm @@ -0,0 +1,162 @@ +#| -*-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)) + +;;;; 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 +) + +;; 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 diff --git a/v8/src/compiler/back/linear.scm b/v8/src/compiler/back/linear.scm new file mode 100644 index 000000000..71a4dff9d --- /dev/null +++ b/v8/src/compiler/back/linear.scm @@ -0,0 +1,279 @@ +#| -*-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)) + +(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)))) + + (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)))))))))) + + (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)) + +(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)))))) + +(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 diff --git a/v8/src/compiler/back/mermap.scm b/v8/src/compiler/back/mermap.scm new file mode 100644 index 000000000..0d5d50754 --- /dev/null +++ b/v8/src/compiler/back/mermap.scm @@ -0,0 +1,179 @@ +#| -*-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)) + +(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)))))) + +(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 diff --git a/v8/src/compiler/back/regmap.scm b/v8/src/compiler/back/regmap.scm new file mode 100644 index 000000000..85589ef17 --- /dev/null +++ b/v8/src/compiler/back/regmap.scm @@ -0,0 +1,1068 @@ +#| -*-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)) + +#| + +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)) + +;;;; 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)) + +;;;; 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*))) + +;;;; 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))))) + +(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))) + +(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))))))))) + +;;;; 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"))) + +(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))))))) + +;;;; 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))))) + +(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 '())))) + +;; 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))))) + +(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?)) + +;;;; 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)))))) + +) + +;; 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)))))))))))))) + +(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))) + +(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 diff --git a/v8/src/compiler/back/syerly.scm b/v8/src/compiler/back/syerly.scm new file mode 100644 index 000000000..4900b9953 --- /dev/null +++ b/v8/src/compiler/back/syerly.scm @@ -0,0 +1,242 @@ +#| -*-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)) + +;;;; 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)))))))))) + +;;;; 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)))) + +;;;; 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)))))))) + +;;;; 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)))))) + +;;;; 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 diff --git a/v8/src/compiler/back/symtab.scm b/v8/src/compiler/back/symtab.scm new file mode 100644 index 000000000..974c155e0 --- /dev/null +++ b/v8/src/compiler/back/symtab.scm @@ -0,0 +1,75 @@ +#| -*-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)) + +(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 diff --git a/v8/src/compiler/back/syntax.scm b/v8/src/compiler/back/syntax.scm new file mode 100644 index 000000000..4b24ecd5d --- /dev/null +++ b/v8/src/compiler/back/syntax.scm @@ -0,0 +1,236 @@ +#| -*-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)) + +(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 + '()) + +(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)))))) + +;;;; 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))) + +;;;; 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