From 159cccc3bb05b4c81e706f6a607273a1b5fb80a2 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Thu, 25 Jan 1990 16:45:49 +0000 Subject: [PATCH] New compiler port. --- v7/src/compiler/machines/spectrum/assmd.scm | 63 +- v7/src/compiler/machines/spectrum/coerce.scm | 219 ++- v7/src/compiler/machines/spectrum/dassm1.scm | 289 ++++ v7/src/compiler/machines/spectrum/dassm2.scm | 254 +++ v7/src/compiler/machines/spectrum/decls.scm | 618 ++++++++ v7/src/compiler/machines/spectrum/lapgen.scm | 1491 ++++++------------ v7/src/compiler/machines/spectrum/machin.scm | 387 +++-- v7/src/compiler/machines/spectrum/rgspcm.scm | 75 + v7/src/compiler/machines/spectrum/rules1.scm | 268 ++++ v7/src/compiler/machines/spectrum/rules2.scm | 85 + v7/src/compiler/machines/spectrum/rules3.scm | 588 +++++++ v7/src/compiler/machines/spectrum/rules4.scm | 101 ++ v7/src/compiler/machines/spectrum/rulfix.scm | 356 +++++ v7/src/compiler/machines/spectrum/rulflo.scm | 187 +++ 14 files changed, 3749 insertions(+), 1232 deletions(-) create mode 100644 v7/src/compiler/machines/spectrum/dassm1.scm create mode 100644 v7/src/compiler/machines/spectrum/dassm2.scm create mode 100644 v7/src/compiler/machines/spectrum/decls.scm create mode 100644 v7/src/compiler/machines/spectrum/rgspcm.scm create mode 100644 v7/src/compiler/machines/spectrum/rules1.scm create mode 100644 v7/src/compiler/machines/spectrum/rules2.scm create mode 100644 v7/src/compiler/machines/spectrum/rules3.scm create mode 100644 v7/src/compiler/machines/spectrum/rules4.scm create mode 100644 v7/src/compiler/machines/spectrum/rulfix.scm create mode 100644 v7/src/compiler/machines/spectrum/rulflo.scm diff --git a/v7/src/compiler/machines/spectrum/assmd.scm b/v7/src/compiler/machines/spectrum/assmd.scm index 2f19b4964..93aa0705e 100644 --- a/v7/src/compiler/machines/spectrum/assmd.scm +++ b/v7/src/compiler/machines/spectrum/assmd.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/assmd.scm,v 1.29 1987/03/19 00:54:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/assmd.scm,v 1.30 1990/01/25 16:28:57 jinx Rel $ +$MC68020-Header: assmd.scm,v 1.36 89/08/28 18:33:33 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,23 +37,55 @@ MIT in each case. |# (declare (usual-integrations)) -(define addressing-granularity 8) -(define scheme-object-width 32) +(let-syntax ((ucode-type (macro (name) `',(microcode-type name)))) -(define make-nmv-header) -(let () +(define-integrable maximum-padding-length + ;; Instruction length is always a multiple of 32 bits + ;; Would 0 work here? + 32) -(set! make-nmv-header -(named-lambda (make-nmv-header n) - (bit-string-append (unsigned-integer->bit-string 24 n) - nmv-type-string))) +(define padding-string + ;; Pad with `DIAG SCM' instructions + (unsigned-integer->bit-string maximum-padding-length + #b00010100010100110100001101001101)) -(define nmv-type-string - (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR))) +(define-integrable block-offset-width + ;; Block offsets are always 16 bit words + 16) + +(define-integrable maximum-block-offset + ;; PC always aligned on longword boundary. Use the extra bit. + (- (expt 2 (1+ block-offset-width)) 4)) + +(define (block-offset->bit-string offset start?) + (unsigned-integer->bit-string block-offset-width + (+ (quotient offset 2) + (if start? 0 1)))) -) +(define (make-nmv-header n) + (bit-string-append (unsigned-integer->bit-string scheme-datum-width n) + nmv-type-string)) + +(define nmv-type-string + (unsigned-integer->bit-string scheme-type-width + (ucode-type manifest-nm-vector))) (define (object->bit-string object) (bit-string-append - (unsigned-integer->bit-string 24 (primitive-datum object)) - (unsigned-integer->bit-string 8 (primitive-type object)))) \ No newline at end of file + (unsigned-integer->bit-string scheme-datum-width + (careful-object-datum object)) + (unsigned-integer->bit-string scheme-type-width (object-type object)))) + +;;; Machine dependent instruction order + +(define (instruction-insert! bits block position receiver) + (let* ((l (bit-string-length bits)) + (new-position (- position l))) + (bit-substring-move-right! bits 0 l block new-position) + (receiver new-position))) + +(define instruction-initial-position bit-string-length) +(define-integrable instruction-append bit-string-append-reversed) + +;;; end let-syntax +) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/coerce.scm b/v7/src/compiler/machines/spectrum/coerce.scm index eb8c4c818..e9e74a1ea 100644 --- a/v7/src/compiler/machines/spectrum/coerce.scm +++ b/v7/src/compiler/machines/spectrum/coerce.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/coerce.scm,v 1.4 1987/03/19 00:54:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/coerce.scm,v 1.5 1990/01/25 16:30:05 jinx Rel $ +$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,39 +33,10 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Spectrum Specific Coercions - (declare (usual-integrations)) -(define (parse-word expression tail) - (expand-descriptors (cdr expression) - (lambda (instruction size) - (if (not (zero? (remainder size 32))) - (error "PARSE-WORD: Instructions must be 32 bit multiples" size)) - (let ((instruction (apply optimize-group-syntax instruction))) - (if (null? tail) - `(CONS ,instruction '()) - `(CONS-SYNTAX ,instruction (CONS ,(car tail) '()))))))) - -(define (expand-descriptors descriptors receiver) - (if (null? descriptors) - (receiver '() 0) - (expand-descriptors (cdr descriptors) - (lambda (instruction* size*) - (expand-descriptor (car descriptors) - (lambda (instruction size) - (receiver (append! instruction instruction*) - (+ size size*)))))))) - -(define (expand-descriptor descriptor receiver) - (let ((size (car descriptor))) - (receiver `(,(integer-syntaxer (cadr descriptor) - (if (null? (cddr descriptor)) - 'UNSIGNED - (caddr descriptor)) - size)) - size))) - +;;;; Strange hppa coercions + (define (coerce-right-signed nbits) (let ((offset (1+ (expt 2 nbits)))) (lambda (n) @@ -73,57 +45,80 @@ MIT in each case. |# (+ (* n 2) offset) (* n 2)))))) -(define coerce-assemble3:x - (standard-coercion - (lambda (n) - (+ (* (land n 3) 2) (quotient n 4))))) - -(define coerce-assemble12:X - (standard-coercion - (lambda (n) - (let ((qr (integer-divide n 4))) - (if (not (zero? (integer-divide-remainder qr))) - (error "COERCE-ASSEMBLE12:X: offset not multiple of 4" n)) - (let ((n (integer-divide-quotient qr))) - (+ (* (land n #x3FF) 2) (quotient (land n #x400) #x400))))))) - -(define coerce-assemble12:Y - (standard-coercion - (lambda (n) - (quotient (land (quotient n 4) #x800) #x800)))) - -(define coerce-assemble17:X - (standard-coercion - (lambda (n) - (let ((qr (integer-divide n 4))) - (if (not (zero? (integer-divide-remainder qr))) - (error "COERCE-ASSEMBLE17:X: offset not multiple of 4" n)) - (quotient (land (integer-divide-quotient qr) #xF800) #x800))))) - -(define coerce-assemble17:Y - (standard-coercion - (lambda (n) - (let ((n (quotient n 4))) - (+ (quotient (land n #x400) #x400) (* (land n #x3FF) 2)))))) - -(define coerce-assemble17:Z - (standard-coercion - (lambda (n) - (+ (quotient (land (quotient n 4) #x10000) #x10000))))) - -(define coerce-assemble21:X - (standard-coercion - (lambda (n) - (+ (* (land n #x7C) #x4000) - (* (land n #x180) #x80) - (* (land n #x3) #x1000) - (quotient (land n #xFFE00) #x100) - (quotient (land n #x100000) #x100000))))) +(define (coerce-assemble12:x nbits) + (let ((range (expt 2 11))) + (lambda (n) + (let ((n (machine-word-offset n range)) + (r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! n 0 10 r 1) + (bit-substring-move-right! n 10 11 r 0) + r)))) + +(define (coerce-assemble12:y nbits) + (let ((range (expt 2 11))) + (lambda (n) + (let ((r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! (machine-word-offset n range) 11 12 r 0) + r)))) + +(define (coerce-assemble17:x nbits) + (let ((range (expt 2 16))) + (lambda (n) + (let ((r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! (machine-word-offset n range) 11 16 r 0) + r)))) + +(define (coerce-assemble17:y nbits) + (let ((range (expt 2 16))) + (lambda (n) + (let ((n (machine-word-offset n range)) + (r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! n 0 10 r 1) + (bit-substring-move-right! n 10 11 r 0) + r)))) + +(define (coerce-assemble17:z nbits) + (let ((range (expt 2 16))) + (lambda (n) + (let ((r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! (machine-word-offset n range) 16 17 r 0) + r)))) + +(define (coerce-assemble21:x nbits) + ;; This one does not check for range. Should it? + (lambda (n) + (let ((n (integer->word n)) + (r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! n 0 2 r 12) + (bit-substring-move-right! n 2 7 r 16) + (bit-substring-move-right! n 7 9 r 14) + (bit-substring-move-right! n 9 20 r 1) + (bit-substring-move-right! n 20 21 r 0) + r))) + +(define (machine-word-offset n range) + (let ((value (integer-divide n 4))) + (if (not (zero? (integer-divide-remainder value))) + (error "machine-word-offset: Invalid offset" n)) + (let ((result (integer-divide-quotient value))) + (if (and (< result range) + (>= result (- range))) + (integer->word result) + (error "machine-word-offset: Doesn't fit" n range))))) + +(define (integer->word x) + (unsigned-integer->bit-string + 32 + (let ((x (if (negative? x) (+ x #x100000000) x))) + (if (not (and (not (negative? x)) (< x #x100000000))) + (error "Integer too large to be encoded" x)) + x))) +;;; Coercion top level + (define make-coercion (coercion-maker - `((ASSEMBLE3:X . ,coerce-assemble3:x) - (ASSEMBLE12:X . ,coerce-assemble12:x) + `((ASSEMBLE12:X . ,coerce-assemble12:x) (ASSEMBLE12:Y . ,coerce-assemble12:y) (ASSEMBLE17:X . ,coerce-assemble17:x) (ASSEMBLE17:Y . ,coerce-assemble17:y) @@ -133,34 +128,34 @@ MIT in each case. |# (UNSIGNED . ,coerce-unsigned-integer) (SIGNED . ,coerce-signed-integer)))) -(define-coercion 'UNSIGNED 1) -(define-coercion 'UNSIGNED 2) -(define-coercion 'UNSIGNED 3) -(define-coercion 'UNSIGNED 4) -(define-coercion 'UNSIGNED 5) -(define-coercion 'UNSIGNED 6) -(define-coercion 'UNSIGNED 7) -(define-coercion 'UNSIGNED 8) -(define-coercion 'UNSIGNED 9) -(define-coercion 'UNSIGNED 10) -(define-coercion 'UNSIGNED 11) -(define-coercion 'UNSIGNED 12) -(define-coercion 'UNSIGNED 13) -(define-coercion 'UNSIGNED 14) -(define-coercion 'UNSIGNED 16) -(define-coercion 'UNSIGNED 32) - -(define-coercion 'SIGNED 8) -(define-coercion 'SIGNED 16) -(define-coercion 'SIGNED 32) - -(define-coercion 'RIGHT-SIGNED 5) -(define-coercion 'RIGHT-SIGNED 11) -(define-coercion 'RIGHT-SIGNED 14) -(define-coercion 'ASSEMBLE3:X 3) -(define-coercion 'ASSEMBLE12:X 11) -(define-coercion 'ASSEMBLE12:Y 1) -(define-coercion 'ASSEMBLE17:X 5) -(define-coercion 'ASSEMBLE17:Y 11) -(define-coercion 'ASSEMBLE17:Z 1) -(define-coercion 'ASSEMBLE21:X 21) \ No newline at end of file +(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1)) +(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2)) +(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3)) +(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4)) +(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5)) +(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6)) +(define coerce-7-bit-unsigned (make-coercion 'UNSIGNED 7)) +(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8)) +(define coerce-9-bit-unsigned (make-coercion 'UNSIGNED 9)) +(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10)) +(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11)) +(define coerce-12-bit-unsigned (make-coercion 'UNSIGNED 12)) +(define coerce-13-bit-unsigned (make-coercion 'UNSIGNED 13)) +(define coerce-14-bit-unsigned (make-coercion 'UNSIGNED 14)) +(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15)) +(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16)) +(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32)) + +(define coerce-8-bit-signed (make-coercion 'SIGNED 8)) +(define coerce-16-bit-signed (make-coercion 'SIGNED 16)) +(define coerce-32-bit-signed (make-coercion 'SIGNED 32)) + +(define coerce-5-bit-right-signed (make-coercion 'RIGHT-SIGNED 5)) +(define coerce-11-bit-right-signed (make-coercion 'RIGHT-SIGNED 11)) +(define coerce-14-bit-right-signed (make-coercion 'RIGHT-SIGNED 14)) +(define coerce-11-bit-assemble12:x (make-coercion 'ASSEMBLE12:X 11)) +(define coerce-1-bit-assemble12:y (make-coercion 'ASSEMBLE12:Y 1)) +(define coerce-5-bit-assemble17:x (make-coercion 'ASSEMBLE17:X 5)) +(define coerce-11-bit-assemble17:y (make-coercion 'ASSEMBLE17:Y 11)) +(define coerce-1-bit-assemble17:z (make-coercion 'ASSEMBLE17:Z 1)) +(define coerce-21-bit-assemble21:x (make-coercion 'ASSEMBLE21:X 21)) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/dassm1.scm b/v7/src/compiler/machines/spectrum/dassm1.scm new file mode 100644 index 000000000..3d51ec217 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/dassm1.scm @@ -0,0 +1,289 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/dassm1.scm,v 4.14 1990/01/25 16:31:23 jinx Exp $ +$MC68020-Header: dassm1.scm,v 4.14 89/10/26 07:37:28 GMT cph Exp $ + +Copyright (c) 1988, 1989, 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. |# + +;;;; Disassembler: User Level + +(declare (usual-integrations)) + +;;; Flags that control disassembler behavior + +(define disassembler/symbolize-output? true) +(define disassembler/compiled-code-heuristics? true) +(define disassembler/write-offsets? true) +(define disassembler/write-addresses? false) + +;;;; Top level entries + +(define (compiler:write-lap-file filename #!optional symbol-table?) + (let ((pathname (->pathname filename))) + (with-output-to-file (pathname-new-type pathname "lap") + (lambda () + (let ((com-file (pathname-new-type pathname "com"))) + (let ((object (fasload com-file)) + (info + (let ((pathname (pathname-new-type pathname "binf"))) + (and (if (default-object? symbol-table?) + (file-exists? pathname) + symbol-table?) + (fasload pathname))))) + (if (compiled-code-address? object) + (disassembler/write-compiled-code-block + (compiled-code-address->block object) + info) + (begin + (if (not + (and (scode/comment? object) + (dbg-info-vector? (scode/comment-text object)))) + (error "Not a compiled file" com-file)) + (let ((items + (vector->list + (dbg-info-vector/blocks-vector + (scode/comment-text object))))) + (if (not (null? items)) + (if (false? info) + (let loop ((items items)) + (disassembler/write-compiled-code-block + (car items) + false) + (if (not (null? (cdr items))) + (begin + (write-char #\page) + (loop (cdr items))))) + (let loop + ((items items) (info (vector->list info))) + (disassembler/write-compiled-code-block + (car items) + (car info)) + (if (not (null? (cdr items))) + (begin + (write-char #\page) + (loop (cdr items) (cdr info)))))))))))))))) + +(define disassembler/base-address) + +(define (compiler:disassemble entry) + (let ((block (compiled-entry/block entry))) + (let ((info (compiled-code-block/dbg-info block true))) + (fluid-let ((disassembler/write-offsets? true) + (disassembler/write-addresses? true) + (disassembler/base-address (object-datum block))) + (newline) + (newline) + (disassembler/write-compiled-code-block block info))))) + +;;; Operations exported from the disassembler package + +(define disassembler/instructions) +(define disassembler/instructions/null?) +(define disassembler/instructions/read) +(define disassembler/lookup-symbol) +(define disassembler/read-variable-cache) +(define disassembler/read-procedure-cache) +(define compiled-code-block/objects-per-procedure-cache) +(define compiled-code-block/objects-per-variable-cache) + +(define (disassembler/write-compiled-code-block block info) + (let ((symbol-table (and info (dbg-info/labels info)))) + (write-string "Disassembly of ") + (write block) + (write-string ":\n") + (write-string "Code:\n\n") + (disassembler/write-instruction-stream + symbol-table + (disassembler/instructions/compiled-code-block block symbol-table)) + (write-string "\nConstants:\n\n") + (disassembler/write-constants-block block symbol-table) + (newline))) + +(define (disassembler/instructions/compiled-code-block block symbol-table) + (disassembler/instructions block + (compiled-code-block/code-start block) + (compiled-code-block/code-end block) + symbol-table)) + +(define (disassembler/instructions/address start-address end-address) + (disassembler/instructions false start-address end-address false)) + +(define (disassembler/write-instruction-stream symbol-table instruction-stream) + (fluid-let ((*unparser-radix* 16)) + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction) + (disassembler/write-instruction symbol-table + offset + (lambda () (display instruction))))))) + +(define (disassembler/for-each-instruction instruction-stream procedure) + (let loop ((instruction-stream instruction-stream)) + (if (not (disassembler/instructions/null? instruction-stream)) + (disassembler/instructions/read instruction-stream + (lambda (offset instruction instruction-stream) + (procedure offset instruction) + (loop (instruction-stream))))))) + +(define (disassembler/write-constants-block block symbol-table) + (fluid-let ((*unparser-radix* 16)) + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/constants-start block))) + (cond ((not (< index end)) 'DONE) + ((object-type? + (let-syntax ((ucode-type + (macro (name) (microcode-type name)))) + (ucode-type linkage-section)) + (system-vector-ref block index)) + (loop (disassembler/write-linkage-section block + symbol-table + index))) + (else + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-constant block + symbol-table + (system-vector-ref block index)))) + (loop (1+ index)))))))) + +(define (write-constant block symbol-table constant) + (write-string (cdr (write-to-string constant 60))) + (cond ((lambda? constant) + (let ((expression (lambda-body constant))) + (if (and (compiled-code-address? expression) + (eq? (compiled-code-address->block expression) block)) + (begin + (write-string " (") + (let ((offset (compiled-code-address->offset expression))) + (let ((label + (disassembler/lookup-symbol symbol-table offset))) + (if label + (write-string label) + (write offset)))) + (write-string ")"))))) + ((compiled-code-address? constant) + (write-string " (offset ") + (write (compiled-code-address->offset constant)) + (write-string " in ") + (write (compiled-code-address->block constant)) + (write-string ")")) + (else false))) + +(define (disassembler/write-linkage-section block symbol-table index) + (define (write-caches index size how-many writer) + (let loop ((index index) (how-many how-many)) + (if (zero? how-many) + 'DONE + (begin + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (writer block index))) + (loop (+ size index) (-1+ how-many)))))) + + (let* ((field (object-datum (system-vector-ref block index))) + (descriptor (integer-divide field #x10000))) + (let ((kind (integer-divide-quotient descriptor)) + (length (integer-divide-remainder descriptor))) + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-string "#[LINKAGE-SECTION ") + (write field) + (write-string "]"))) + (write-caches + (1+ index) + compiled-code-block/objects-per-procedure-cache + (quotient length compiled-code-block/objects-per-procedure-cache) + (case kind + ((0) + disassembler/write-procedure-cache) + ((1) + (lambda (block index) + (disassembler/write-variable-cache "Reference" block index))) + ((2) + (lambda (block index) + (disassembler/write-variable-cache "Assignment" block index))) + (else + (error "disassembler/write-linkage-section: Unknown section kind" + kind)))) + (1+ (+ index length))))) + +(define-integrable (variable-cache-name cache) + ((ucode-primitive primitive-object-ref 2) cache 1)) + +(define (disassembler/write-variable-cache kind block index) + (write-string kind) + (write-string " cache to ") + (write (variable-cache-name (disassembler/read-variable-cache block index)))) + +(define (disassembler/write-procedure-cache block index) + (let ((result (disassembler/read-procedure-cache block index))) + (write (vector-ref result 2)) + (write-string " argument procedure cache to ") + (case (vector-ref result 0) + ((COMPILED INTERPRETED) + (write (vector-ref result 1))) + ((VARIABLE) + (write-string "variable ") + (write (vector-ref result 1))) + (else + (error "disassembler/write-procedure-cache: Unknown cache kind" + (vector-ref result 0)))))) + +(define (disassembler/write-instruction symbol-table offset write-instruction) + (if symbol-table + (let ((label (dbg-labels/find-offset symbol-table offset))) + (if label + (begin + (write-char #\Tab) + (write-string (dbg-label/name label)) + (write-char #\:) + (newline))))) + + (if disassembler/write-addresses? + (begin + (write-string + (number->string (+ offset disassembler/base-address) 16)) + (write-char #\Tab))) + + (if disassembler/write-offsets? + (begin + (write-string (number->string offset 16)) + (write-char #\Tab))) + + (if symbol-table + (write-string " ")) + (write-instruction) + (newline)) diff --git a/v7/src/compiler/machines/spectrum/dassm2.scm b/v7/src/compiler/machines/spectrum/dassm2.scm new file mode 100644 index 000000000..8940e993c --- /dev/null +++ b/v7/src/compiler/machines/spectrum/dassm2.scm @@ -0,0 +1,254 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/dassm2.scm,v 4.16 1990/01/25 16:32:26 jinx Exp $ +$MC68020-Header: dassm2.scm,v 4.16 89/12/11 06:16:42 GMT cph Exp $ + +Copyright (c) 1988, 1989, 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. |# + +;;;; Spectrum Disassembler: Top Level + +(declare (usual-integrations)) + +(set! compiled-code-block/bytes-per-object 4) +(set! compiled-code-block/objects-per-procedure-cache 3) +(set! compiled-code-block/objects-per-variable-cache 1) + +(set! disassembler/read-variable-cache + (lambda (block index) + (let-syntax ((ucode-type + (macro (name) (microcode-type name))) + (ucode-primitive + (macro (name arity) + (make-primitive-procedure name arity)))) + ((ucode-primitive primitive-object-set-type 2) + (ucode-type quad) + (system-vector-ref block index))))) + +(set! disassembler/read-procedure-cache + (lambda (block index) + (fluid-let ((*block block)) + (let* ((offset (compiled-code-block/index->offset index))) + ;; For now + (error "disassembler/read-procedure-cache: Not written"))))) + +(set! disassembler/instructions + (lambda (block start-offset end-offset symbol-table) + (let loop ((offset start-offset) (state (disassembler/initial-state))) + (if (and end-offset (< offset end-offset)) + (disassemble-one-instruction block offset symbol-table state + (lambda (offset* instruction state) + (make-instruction offset + instruction + (lambda () (loop offset* state))))) + '())))) + +(set! disassembler/instructions/null? + null?) + +(set! disassembler/instructions/read + (lambda (instruction-stream receiver) + (receiver (instruction-offset instruction-stream) + (instruction-instruction instruction-stream) + (instruction-next instruction-stream)))) + +(define-structure (instruction (type vector)) + (offset false read-only true) + (instruction false read-only true) + (next false read-only true)) + +(define *block) +(define *current-offset) +(define *symbol-table) +(define *ir) +(define *valid?) + +(define (disassemble-one-instruction block offset symbol-table state receiver) + (fluid-let ((*block block) + (*current-offset offset) + (*symbol-table symbol-table) + (*ir) + (*valid? true)) + (set! *ir (get-longword)) + (let ((start-offset *current-offset)) + (if (external-label-marker? symbol-table offset state) + (receiver *current-offset + (make-external-label *ir) + 'INSTRUCTION) + (let ((instruction (disassemble-word *ir))) + (if (not *valid?) + (let ((inst (make-word *ir))) + (receiver start-offset + inst + (disassembler/next-state inst state))) + (let ((next-state (disassembler/next-state instruction state))) + (receiver + *current-offset + (cond ((and (pair? state) + (eq? (car state) 'PC-REL-LOW-OFFSET)) + (pc-relative-inst offset instruction (cadr state))) + ((and (eq? 'PC-REL-OFFSET state) + (not (pair? next-state))) + (pc-relative-inst offset instruction false)) + (else + instruction)) + next-state)))))))) + +(define (pc-relative-inst start-address instruction left-side) + (let ((opcode (car instruction))) + (if (not (memq opcode '(LDO LDW))) + instruction + (let ((offset-exp (caddr instruction)) + (target (cadddr instruction))) + (let ((offset (cadr offset-exp)) + (space-reg (caddr offset-exp)) + (base-reg (cadddr offset-exp))) + (let* ((real-address + (+ start-address + offset + (if (not left-side) + 0 + (- (let ((val (* left-side #x800))) + (if (>= val #x80000000) + (- val #x100000000) + val)) + 4)))) + (label + (disassembler/lookup-symbol *symbol-table real-address))) + (if (not label) + instruction + `(,opcode () (OFFSET ,(if left-side + `(RIGHT (- ,label (- *PC* 4))) + `(- ,label *PC*)) + ,space-reg + ,base-reg) + ,target)))))))) + +(define (disassembler/initial-state) + 'INSTRUCTION-NEXT) + +(define (disassembler/next-state instruction state) + (cond ((not disassembler/compiled-code-heuristics?) + 'INSTRUCTION) + ((and (eq? state 'INSTRUCTION) + (equal? instruction '(BL () 1 (@PCO 0)))) + 'PC-REL-DEP) + ((and (eq? state 'PC-REL-DEP) + (equal? instruction '(DEP () 0 31 2 1))) + 'PC-REL-OFFSET) + ((and (eq? state 'PC-REL-OFFSET) + (= (length instruction) 4) + (equal? (list (car instruction) + (cadr instruction) + (cadddr instruction)) + '(ADDIL () 1))) + (list 'PC-REL-LOW-OFFSET (caddr instruction))) + ((memq (car instruction) '(B BV BLE)) + 'EXTERNAL-LABEL) + (else + 'INSTRUCTION))) + +(set! disassembler/lookup-symbol + (lambda (symbol-table offset) + (and symbol-table + (let ((label (dbg-labels/find-offset symbol-table offset))) + (and label + (dbg-label/name label)))))) + +(define (external-label-marker? symbol-table offset state) + (if symbol-table + (let ((label (dbg-labels/find-offset symbol-table (+ offset 4)))) + (and label + (dbg-label/external? label))) + (and *block + (not (eq? state 'INSTRUCTION)) + (let loop ((offset (+ offset 4))) + (let ((contents (read-bits (- offset 2) 16))) + (if (bit-string-clear! contents 0) + (let ((offset + (- offset (* 2 (bit-string->unsigned-integer contents))))) + (and (positive? offset) + (loop offset))) + (= offset (* 2 (bit-string->unsigned-integer contents))))))))) + +(define (make-word bit-string) + `(UWORD ,(bit-string->unsigned-integer bit-string))) + +(define (make-external-label bit-string) + `(EXTERNAL-LABEL ,(extract bit-string 16 32) + (@PCO ,(* 4 (extract bit-string 1 16))))) + +#| +;;; 68k version + +(define (read-procedure offset) + (with-absolutely-no-interrupts + (lambda () + (let-syntax ((ucode-type + (macro (name) (microcode-type name))) + (ucode-primitive + (macro (name arity) + (make-primitive-procedure name arity)))) + ((ucode-primitive primitive-object-set-type 2) + (ucode-type compiled-entry) + ((ucode-primitive make-non-pointer-object 1) + (read-unsigned-integer offset 32))))))) +|# + +(define (read-procedure offset) + (error "read-procedure: Called" offset)) + +(define (read-unsigned-integer offset size) + (bit-string->unsigned-integer (read-bits offset size))) + +(define (read-bits offset size-in-bits) + (let ((word (bit-string-allocate size-in-bits)) + (bit-offset (* offset addressing-granularity))) + (with-absolutely-no-interrupts + (lambda () + (if *block + (read-bits! *block bit-offset word) + (read-bits! offset 0 word)))) + word)) + +(define (invalid-instruction) + (set! *valid? false) + false) + +(define (offset->pc-relative pco reference-offset) + (if (not disassembler/symbolize-output?) + `(@PCO ,pco) + ;; Only add 4 because it has already been bumped to the + ;; next instruction. + (let* ((absolute (+ pco (+ 4 reference-offset))) + (label (disassembler/lookup-symbol *symbol-table absolute))) + (if label + `(@PCR ,label) + `(@PCO ,pco))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/decls.scm b/v7/src/compiler/machines/spectrum/decls.scm new file mode 100644 index 000000000..566eaceaa --- /dev/null +++ b/v7/src/compiler/machines/spectrum/decls.scm @@ -0,0 +1,618 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/decls.scm,v 4.25 1990/01/25 16:34:14 jinx Exp $ +$MC68020-Header: decls.scm,v 4.25 90/01/18 22:43:31 GMT cph Exp $ + +Copyright (c) 1988, 1989, 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. |# + +;;;; Compiler File Dependencies + +(declare (usual-integrations)) + +(define (initialize-package!) + (add-event-receiver! event:after-restore reset-source-nodes!) + (reset-source-nodes!)) + +(define (reset-source-nodes!) + (set! source-filenames '()) + (set! source-hash) + (set! source-nodes) + (set! source-nodes/by-rank)) + +(define (maybe-setup-source-nodes!) + (if (null? source-filenames) + (setup-source-nodes!))) + +(define (setup-source-nodes!) + (let ((filenames + (mapcan (lambda (subdirectory) + (map (lambda (pathname) + (string-append subdirectory + "/" + (pathname-name pathname))) + (directory-read + (string-append subdirectory + "/" + source-file-expression)))) + '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt" + "machines/spectrum")))) + (if (null? filenames) + (error "Can't find source files of compiler")) + (set! source-filenames filenames)) + (set! source-hash + (make/hash-table + 101 + string-hash-mod + (lambda (filename source-node) + (string=? filename (source-node/filename source-node))) + make/source-node)) + (set! source-nodes + (map (lambda (filename) + (hash-table/intern! source-hash + filename + identity-procedure + identity-procedure)) + source-filenames)) + (initialize/syntax-dependencies!) + (initialize/integration-dependencies!) + (initialize/expansion-dependencies!) + (source-nodes/rank!)) + +(define source-file-expression "*.scm") +(define source-filenames) +(define source-hash) +(define source-nodes) +(define source-nodes/by-rank) + +(define (filename/append directory . names) + (map (lambda (name) (string-append directory "/" name)) names)) + +(define-structure (source-node + (conc-name source-node/) + (constructor make/source-node (filename))) + (filename false read-only true) + (pathname (string->pathname filename) read-only true) + (forward-links '()) + (backward-links '()) + (forward-closure '()) + (backward-closure '()) + (dependencies '()) + (dependents '()) + (rank false) + (syntax-table false) + (declarations '()) + (modification-time false)) + +(define (filename->source-node filename) + (hash-table/lookup source-hash + filename + identity-procedure + (lambda () (error "Unknown source file" filename)))) + +(define (source-node/circular? node) + (memq node (source-node/backward-closure node))) + +(define (source-node/link! node dependency) + (if (not (memq dependency (source-node/backward-links node))) + (begin + (set-source-node/backward-links! + node + (cons dependency (source-node/backward-links node))) + (set-source-node/forward-links! + dependency + (cons node (source-node/forward-links dependency))) + (source-node/close! node dependency)))) + +(define (source-node/close! node dependency) + (if (not (memq dependency (source-node/backward-closure node))) + (begin + (set-source-node/backward-closure! + node + (cons dependency (source-node/backward-closure node))) + (set-source-node/forward-closure! + dependency + (cons node (source-node/forward-closure dependency))) + (for-each (lambda (dependency) + (source-node/close! node dependency)) + (source-node/backward-closure dependency)) + (for-each (lambda (node) + (source-node/close! node dependency)) + (source-node/forward-closure node))))) + +;;;; Rank + +(define (source-nodes/rank!) + (compute-dependencies! source-nodes) + (compute-ranks! source-nodes) + (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))) + +(define (compute-dependencies! nodes) + (for-each (lambda (node) + (set-source-node/dependencies! + node + (list-transform-negative (source-node/backward-closure node) + (lambda (node*) + (memq node (source-node/backward-closure node*))))) + (set-source-node/dependents! + node + (list-transform-negative (source-node/forward-closure node) + (lambda (node*) + (memq node (source-node/forward-closure node*)))))) + nodes)) + +(define (compute-ranks! nodes) + (let loop ((nodes nodes) (unranked-nodes '())) + (if (null? nodes) + (if (not (null? unranked-nodes)) + (loop unranked-nodes '())) + (loop (cdr nodes) + (let ((node (car nodes))) + (let ((rank (source-node/rank* node))) + (if rank + (begin + (set-source-node/rank! node rank) + unranked-nodes) + (cons node unranked-nodes)))))))) + +(define (source-node/rank* node) + (let loop ((nodes (source-node/dependencies node)) (rank -1)) + (if (null? nodes) + (1+ rank) + (let ((rank* (source-node/rank (car nodes)))) + (and rank* + (loop (cdr nodes) (max rank rank*))))))) + +(define (source-nodes/sort-by-rank nodes) + (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y))))) + +;;;; File Syntaxer + +(define (syntax-files!) + (maybe-setup-source-nodes!) + (for-each + (lambda (node) + (let ((modification-time + (let ((source (modification-time node "scm")) + (binary (modification-time node "bin"))) + (if (not source) + (error "Missing source file" (source-node/filename node))) + (and binary (< source binary) binary)))) + (set-source-node/modification-time! node modification-time) + (if (not modification-time) + (begin (write-string "\nSource file newer than binary: ") + (write (source-node/filename node)))))) + source-nodes) + (if compiler:enable-integration-declarations? + (begin + (for-each + (lambda (node) + (let ((time (source-node/modification-time node))) + (if (and time + (there-exists? (source-node/dependencies node) + (lambda (node*) + (let ((newer? + (let ((time* + (source-node/modification-time node*))) + (or (not time*) + (> time* time))))) + (if newer? + (begin + (write-string "\nBinary file ") + (write (source-node/filename node)) + (write-string " newer than dependency ") + (write (source-node/filename node*)))) + newer?)))) + (set-source-node/modification-time! node false)))) + source-nodes) + (for-each + (lambda (node) + (if (not (source-node/modification-time node)) + (for-each (lambda (node*) + (if (source-node/modification-time node*) + (begin + (write-string "\nBinary file ") + (write (source-node/filename node*)) + (write-string " depends on ") + (write (source-node/filename node)))) + (set-source-node/modification-time! node* false)) + (source-node/forward-closure node)))) + source-nodes))) + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (pathname-delete! + (pathname-new-type (source-node/pathname node) "ext")))) + source-nodes/by-rank) + (write-string "\n\nBegin pass 1:") + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (source-node/syntax! node))) + source-nodes/by-rank) + (if (there-exists? source-nodes/by-rank + (lambda (node) + (and (not (source-node/modification-time node)) + (source-node/circular? node)))) + (begin + (write-string "\n\nBegin pass 2:") + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (if (source-node/circular? node) + (source-node/syntax! node) + (source-node/touch! node)))) + source-nodes/by-rank)))) + +(define (source-node/touch! node) + (with-values + (lambda () + (sf/pathname-defaulting (source-node/pathname node) "" false)) + (lambda (input-pathname bin-pathname spec-pathname) + input-pathname + (pathname-touch! bin-pathname) + (pathname-touch! (pathname-new-type bin-pathname "ext")) + (if spec-pathname (pathname-touch! spec-pathname))))) + +(define (pathname-touch! pathname) + (if (file-exists? pathname) + (begin + (write-string "\nTouch file: ") + (write (pathname->string pathname)) + (file-touch pathname)))) + +(define (pathname-delete! pathname) + (if (file-exists? pathname) + (begin + (write-string "\nDelete file: ") + (write (pathname->string pathname)) + (delete-file pathname)))) + +(define (sc filename) + (maybe-setup-source-nodes!) + (source-node/syntax! (filename->source-node filename))) + +(define (source-node/syntax! node) + (with-values + (lambda () + (sf/pathname-defaulting (source-node/pathname node) "" false)) + (lambda (input-pathname bin-pathname spec-pathname) + (sf/internal + input-pathname bin-pathname spec-pathname + (source-node/syntax-table node) + ((if compiler:enable-integration-declarations? + identity-procedure + (lambda (declarations) + (list-transform-negative declarations + integration-declaration?))) + ((if compiler:enable-expansion-declarations? + identity-procedure + (lambda (declarations) + (list-transform-negative declarations + expansion-declaration?))) + (source-node/declarations node))))))) + +(define-integrable (modification-time node type) + (file-modification-time + (pathname-new-type (source-node/pathname node) type))) + +;;;; Syntax dependencies + +(define (initialize/syntax-dependencies!) + (let ((file-dependency/syntax/join + (lambda (filenames syntax-table) + (for-each (lambda (filename) + (set-source-node/syntax-table! + (filename->source-node filename) + syntax-table)) + filenames)))) + (file-dependency/syntax/join + (append (filename/append "base" + "blocks" "cfg1" "cfg2" "cfg3" "constr" + "contin" "crstop" "ctypes" "debug" "enumer" + "infnew" "lvalue" "object" "pmerly" "proced" + "refctx" "rvalue" "scode" "sets" "subprb" + "toplev" "utils") + (filename/append "back" + "asmmac" "bittop" "bitutl" "insseq" "lapgn1" + "lapgn2" "lapgn3" "linear" "regmap" "symtab" + "syntax") + (filename/append "machines/spectrum" + "dassm1" "insmac" "machin" "rgspcm" "rulrew" + "switch") + (filename/append "fggen" + "declar" "fggen" "canon") + (filename/append "fgopt" + "blktyp" "closan" "conect" "contan" "delint" + "desenv" "envopt" "folcon" "offset" "operan" + "order" "outer" "param" "reord" "reteqv" "reuse" + "sideff" "simapp" "simple" "subfre" "varind") + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" + "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2" + "valclass") + (filename/append "rtlgen" + "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" + "rgretn" "rgrval" "rgstmt" "rtlgen") + (filename/append "rtlopt" + "ralloc" "rcompr" "rcse1" "rcse2" "rcseep" + "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow" + "rerite" "rinvex" "rlife" "rtlcsm")) + compiler-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/spectrum" + "lapgen" + "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo") + lap-generator-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/spectrum" "instr1" "instr2" "instr3") + assembler-syntax-table))) + +;;;; Integration Dependencies + +(define (initialize/integration-dependencies!) + + (define (add-declaration! declaration filenames) + (for-each (lambda (filenames) + (let ((node (filename->source-node filenames))) + (set-source-node/declarations! + node + (cons declaration + (source-node/declarations node))))) + filenames)) + + (let ((front-end-base + (filename/append "base" + "blocks" "cfg1" "cfg2" "cfg3" + "contin" "ctypes" "enumer" "lvalue" + "object" "proced" "rvalue" + "scode" "subprb" "utils")) + (spectrum-base + (filename/append "machines/spectrum" "machin")) + (rtl-base + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlobj" + "rtlreg" "rtlty1" "rtlty2")) + (cse-base + (filename/append "rtlopt" + "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr")) + (instruction-base + (filename/append "machines/spectrum" "assmd" "machin")) + (lapgen-base + (append (filename/append "back" "lapgn3" "regmap") + (filename/append "machines/spectrum" "lapgen"))) + (assembler-base + (append (filename/append "back" "symtab") + (filename/append "machines/spectrum" "instr1"))) + (lapgen-body + (append + (filename/append "back" "lapgn1" "lapgn2" "syntax") + (filename/append "machines/spectrum" + "rules1" "rules2" "rules3" "rules4" + "rulfix" "rulflo"))) + (assembler-body + (append + (filename/append "back" "bittop") + (filename/append "machines/spectrum" + "instr1" "instr2" "instr3")))) + + (define (file-dependency/integration/join filenames dependencies) + (for-each (lambda (filename) + (file-dependency/integration/make filename dependencies)) + filenames)) + + (define (file-dependency/integration/make filename dependencies) + (let ((node (filename->source-node filename))) + (for-each (lambda (dependency) + (let ((node* (filename->source-node dependency))) + (if (not (eq? node node*)) + (source-node/link! node node*)))) + dependencies))) + + (define (define-integration-dependencies directory name directory* . names) + (file-dependency/integration/make + (string-append directory "/" name) + (apply filename/append directory* names))) + + (define-integration-dependencies "base" "object" "base" "enumer") + (define-integration-dependencies "base" "enumer" "base" "object") + (define-integration-dependencies "base" "utils" "base" "scode") + (define-integration-dependencies "base" "cfg1" "base" "object") + (define-integration-dependencies "base" "cfg2" "base" + "cfg1" "cfg3" "object") + (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2") + (define-integration-dependencies "base" "ctypes" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb") + (define-integration-dependencies "base" "rvalue" "base" + "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils") + (define-integration-dependencies "base" "lvalue" "base" + "blocks" "object" "proced" "rvalue" "utils") + (define-integration-dependencies "base" "blocks" "base" + "enumer" "lvalue" "object" "proced" "rvalue" "scode") + (define-integration-dependencies "base" "proced" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object" + "rvalue" "utils") + (define-integration-dependencies "base" "contin" "base" + "blocks" "cfg3" "ctypes") + (define-integration-dependencies "base" "subprb" "base" + "cfg3" "contin" "enumer" "object" "proced") + + (define-integration-dependencies "machines/spectrum" "machin" "rtlbase" + "rtlreg" "rtlty1" "rtlty2") + + (define-integration-dependencies "rtlbase" "regset" "base") + (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2") + (define-integration-dependencies "rtlbase" "rgraph" "machines/spectrum" + "machin") + (define-integration-dependencies "rtlbase" "rtlcfg" "base" + "cfg1" "cfg2" "cfg3") + (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils") + (define-integration-dependencies "rtlbase" "rtlcon" "machines/spectrum" + "machin") + (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" + "rtlreg" "rtlty1") + (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2") + (define-integration-dependencies "rtlbase" "rtline" "rtlbase" + "rtlcfg" "rtlty2") + (define-integration-dependencies "rtlbase" "rtlobj" "base" + "cfg1" "object" "utils") + (define-integration-dependencies "rtlbase" "rtlreg" "machines/spectrum" + "machin") + (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase" + "rgraph" "rtlty1") + (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg") + (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode") + (define-integration-dependencies "rtlbase" "rtlty2" "machines/spectrum" + "machin") + (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1") + + (file-dependency/integration/join + (append + (filename/append "base" "refctx") + (filename/append "fggen" + "declar" "fggen") ; "canon" needs no integrations + (filename/append "fgopt" + "blktyp" "closan" "conect" "contan" "delint" "desenv" + "envopt" "folcon" "offset" "operan" "order" "param" + "outer" "reuse" "reteqv" "sideff" "simapp" "simple" + "subfre" "varind")) + (append spectrum-base front-end-base)) + + (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord") + + (file-dependency/integration/join + (filename/append "rtlgen" + "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn" + "rgrval" "rgstmt" "rtlgen") + (append spectrum-base front-end-base rtl-base)) + + (file-dependency/integration/join + (append cse-base + (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow" + "rerite" "rinvex" "rlife" "rtlcsm") + (filename/append "machines/spectrum" "rulrew")) + (append spectrum-base rtl-base)) + + (file-dependency/integration/join cse-base cse-base) + + (define-integration-dependencies "rtlopt" "rcseht" "base" "object") + (define-integration-dependencies "rtlopt" "rcserq" "base" "object") + (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2") + + (let ((dependents + (append instruction-base + lapgen-base + lapgen-body + assembler-base + assembler-body + (filename/append "back" "linear" "syerly")))) + (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents) + (file-dependency/integration/join dependents instruction-base)) + + (file-dependency/integration/join (append lapgen-base lapgen-body) + lapgen-base) + + (file-dependency/integration/join (append assembler-base assembler-body) + assembler-base) + + (define-integration-dependencies "back" "lapgn1" "base" + "cfg1" "cfg2" "utils") + (define-integration-dependencies "back" "lapgn1" "rtlbase" + "regset" "rgraph" "rtlcfg") + (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg") + (define-integration-dependencies "back" "lapgn3" "rtlbase" "rtlcfg") + (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2") + (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg") + (define-integration-dependencies "back" "mermap" "back" "regmap") + (define-integration-dependencies "back" "regmap" "base" "utils") + (define-integration-dependencies "back" "symtab" "base" "utils")) + + (for-each (lambda (node) + (let ((links (source-node/backward-links node))) + (if (not (null? links)) + (set-source-node/declarations! + node + (cons (make-integration-declaration + (source-node/pathname node) + (map source-node/pathname links)) + (source-node/declarations node)))))) + source-nodes)) + +(define (make-integration-declaration pathname integration-dependencies) + `(INTEGRATE-EXTERNAL + ,@(map (let ((default + (make-pathname + false + false + (make-list (length (pathname-directory pathname)) 'UP) + false + false + false))) + (lambda (pathname) + (merge-pathnames pathname default))) + integration-dependencies))) + +(define-integrable (integration-declaration? declaration) + (eq? (car declaration) 'INTEGRATE-EXTERNAL)) + +;;;; Expansion Dependencies + +(define (initialize/expansion-dependencies!) + (let ((file-dependency/expansion/join + (lambda (filenames expansions) + (for-each (lambda (filename) + (let ((node (filename->source-node filename))) + (set-source-node/declarations! + node + (cons (make-expansion-declaration expansions) + (source-node/declarations node))))) + filenames)))) + (file-dependency/expansion/join + (filename/append "machines/spectrum" + "lapgen" "rules1" "rules2" "rules3" "rules4" + "rulfix" "rulflo") + (map (lambda (entry) + `(,(car entry) + (PACKAGE/REFERENCE (FIND-PACKAGE '(COMPILER LAP-SYNTAXER)) + ',(cadr entry)))) + '((LAP:SYNTAX-INSTRUCTION LAP:SYNTAX-INSTRUCTION-EXPANDER) + (INSTRUCTION->INSTRUCTION-SEQUENCE + INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER) + (SYNTAX-EVALUATION SYNTAX-EVALUATION-EXPANDER) + (CONS-SYNTAX CONS-SYNTAX-EXPANDER) + (OPTIMIZE-GROUP-EARLY OPTIMIZE-GROUP-EXPANDER) + (EA-KEYWORD-EARLY EA-KEYWORD-EXPANDER) + (EA-MODE-EARLY EA-MODE-EXPANDER) + (EA-REGISTER-EARLY EA-REGISTER-EXPANDER) + (EA-EXTENSION-EARLY EA-EXTENSION-EXPANDER) + (EA-CATEGORIES-EARLY EA-CATEGORIES-EXPANDER)))))) + +(define-integrable (make-expansion-declaration expansions) + `(EXPAND-OPERATOR ,@expansions)) + +(define-integrable (expansion-declaration? declaration) + (eq? (car declaration) 'EXPAND-OPERATOR)) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/lapgen.scm b/v7/src/compiler/machines/spectrum/lapgen.scm index ce8d90ebf..a59d81c2c 100644 --- a/v7/src/compiler/machines/spectrum/lapgen.scm +++ b/v7/src/compiler/machines/spectrum/lapgen.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/lapgen.scm,v 1.137 1987/04/12 00:25:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/lapgen.scm,v 4.26 1990/01/25 16:38:08 jinx Exp $ +$MC68020-Header: lapgen.scm,v 4.26 90/01/18 22:43:36 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,1010 +33,538 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; RTL Rules for Spectrum +;;;; RTL Rules for HPPA. Shared utilities. (declare (usual-integrations)) -;;;; Interface to Allocator - -(define (register->register-transfer source destination) - `(,(machine->machine-register source destination))) +;;;; Register-Allocator Interface + +(define (register->register-transfer source target) + (if (not (register-types-compatible? source target)) + (error "Moving between incompatible register types" source target)) + (case (register-type source) + ((GENERAL) (copy source target)) + ((FLOAT) (fp-copy source target)) + (else (error "unknown register type" source)))) + +(define (home->register-transfer source target) + (memory->register-transfer (pseudo-register-displacement source) + regnum:regs-pointer + target)) + +(define (register->home-transfer source target) + (register->memory-transfer source + (pseudo-register-displacement target) + regnum:regs-pointer)) + +(define (reference->register-transfer source target) + (case (ea/mode source) + ((GR) + (copy (register-ea/register source) target)) + ((FPR) + (fp-copy (fpr->float-register (register-ea/register source)) target)) + ((OFFSET) + (memory->register-transfer (offset-ea/offset source) + (offset-ea/register source) + target)) + (else + (error "unknown effective-address mode" source)))) + +(define (pseudo-register-home register) + ;; Register block consists of 16 4-byte registers followed by 256 + ;; 8-byte temporaries. + (INST-EA (OFFSET ,(pseudo-register-displacement register) + 0 + ,regnum:regs-pointer))) + +(define-integrable (sort-machine-registers registers) + registers) + +(define available-machine-registers + ;; g1 removed from this list since it is the target of ADDIL, + ;; needed to expand some rules. g31 may want to be removed + ;; too. + (list + ;; g0 g1 g2 g3 g4 g5 + g6 g7 g8 g9 g10 g11 g12 g13 g14 g15 g16 g17 g18 + ;; g19 g20 g21 g22 + g23 g24 g25 g26 + ;; g27 + g28 g29 + ;; g30 + g31 + ;; fp0 fp1 fp2 fp3 + fp4 fp5 fp6 fp6 fp7 fp8 fp9 fp10 fp11 fp12 fp13 fp14 fp15 + )) + +(define-integrable (float-register? register) + (eq? (register-type register) 'FLOAT)) + +(define-integrable (general-register? register) + (eq? (register-type register) 'GENERAL)) + +(define-integrable (word-register? register) + (eq? (register-type register) 'GENERAL)) + +(define (register-types-compatible? type1 type2) + (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT))) + +(define (register-type register) + (cond ((machine-register? register) + (vector-ref + '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT) + register)) + ((register-value-class=word? register) 'GENERAL) + ((register-value-class=float? register) 'FLOAT) + (else (error "unable to determine register type" register)))) + +(define register-reference + (let ((references (make-vector number-of-machine-registers))) + (let loop ((register 0)) + (if (< register 32) + (begin + (vector-set! references register (INST-EA (GR ,register))) + (loop (1+ register))))) + (let loop ((register 32) (fpr 0)) + (if (< register 48) + (begin + (vector-set! references register (INST-EA (FPR ,fpr))) + (loop (1+ register) (1+ fpr))))) + (lambda (register) + (vector-ref references register)))) + +;;;; Useful Cliches + +(define (memory->register-transfer offset base target) + (case (register-type target) + ((GENERAL) (load-word offset base target)) + ((FLOAT) (fp-load-doubleword offset base target)) + (else (error "unknown register type" target)))) + +(define (register->memory-transfer source offset base) + (case (register-type source) + ((GENERAL) (store-word source offset base)) + ((FLOAT) (fp-store-doubleword source offset base)) + (else (error "unknown register type" source)))) + +(define (load-constant constant target) + ;; Load a Scheme constant into a machine register. + (if (non-pointer-object? constant) + (load-immediate (non-pointer->literal constant) target) + (load-pc-relative (constant->label constant) target))) -(define (home->register-transfer source destination) - `(,(pseudo->machine-register source destination))) +(define (load-non-pointer type datum target) + ;; Load a Scheme non-pointer constant, defined by type and datum, + ;; into a machine register. + (load-immediate (make-non-pointer-literal type datum) target)) -(define (register->home-transfer source destination) - `(,(machine->pseudo-register source destination))) +(define (non-pointer->literal constant) + (make-non-pointer-literal (object-type constant) + (careful-object-datum constant))) -(define-integrable (pseudo->machine-register source target) - (memory->machine-register (pseudo-register-home source) target)) +(define-integrable (make-non-pointer-literal type datum) + (+ (* type type-scale-factor) datum)) -(define-integrable (machine->pseudo-register source target) - (machine-register->memory source (pseudo-register-home target))) +(define-integrable type-scale-factor + (expt 2 scheme-datum-width)) -(define-integrable (pseudo-register-home register) - (index-reference regnum:regs-pointer - (+ #x000A (register-renumber register)))) +(define-integrable (deposit-type type target) + (deposit-immediate type (-1+ scheme-type-width) scheme-type-width target)) -;;;; Basic machine instructions - -(define-integrable (machine->machine-register source target) - `(OR () ,source 0 ,target)) - -(define-integrable (machine-register->memory source target) - `(STW () ,source ,target)) +;;;; Regularized Machine Instructions + +(define (copy r t) + (if (= r t) + (LAP) + (LAP (COPY () ,r ,t)))) + +(define (load-immediate i t) + (if (fits-in-14-bits-signed? i) + (LAP (LDI () ,i ,t)) + (let ((split (integer-divide i (expt 2 11)))) + (LAP (LDIL () ,(integer-divide-quotient split) ,t) + ,@(let ((r%i (integer-divide-remainder split))) + (if (zero? r%i) + (LAP) + (LAP (LDO () (OFFSET ,r%i 0 ,t) ,t)))))))) + +(define (deposit-immediate i p len t) + (if (fits-in-5-bits-signed? i) + (LAP (DEPI () ,i ,p ,len ,t)) + (LAP ,@(load-immediate i regnum:addil-result) + (DEP () ,regnum:addil-result ,p ,len ,t)))) + +(define (load-offset d b t) + (cond ((and (zero? d) (= b t)) + (LAP)) + ((fits-in-14-bits-signed? d) + (LAP (LDO () (OFFSET ,d 0 ,b) ,t))) + (else + (let ((split (integer-divide d (expt 2 11)))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,b) + (LDO () (OFFSET ,(integer-divide-remainder split) 0 1) ,t)))))) + +(define (load-word d b t) + (if (fits-in-14-bits-signed? d) + (LAP (LDW () (OFFSET ,d 0 ,b) ,t)) + (let ((split (integer-divide d (expt 2 11)))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,b) + (LDW () (OFFSET ,(integer-divide-remainder split) 0 1) ,t))))) + +(define (load-byte d b t) + (if (fits-in-14-bits-signed? d) + (LAP (LDB () (OFFSET ,d 0 ,b) ,t)) + (let ((split (integer-divide d (expt 2 11)))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,b) + (LDB () (OFFSET ,(integer-divide-remainder split) 0 1) ,t))))) + +(define (store-word b d t) + (if (fits-in-14-bits-signed? d) + (LAP (STW () ,b (OFFSET ,d 0 ,t))) + (let ((split (integer-divide d (expt 2 11)))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,t) + (STW () ,b (OFFSET ,(integer-divide-remainder split) 0 1)))))) + +(define (store-byte b d t) + (if (fits-in-14-bits-signed? d) + (LAP (STB () ,b (OFFSET ,d 0 ,t))) + (let ((split (integer-divide d (expt 2 11)))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,t) + (STB () ,b (OFFSET ,(integer-divide-remainder split) 0 1)))))) + +(define (fp-copy r t) + (if (= r t) + (LAP) + (LAP (FCPY (DBL) ,(float-register->fpr r) ,(float-register->fpr t))))) + +(define (fp-load-doubleword d b t) + (let ((t (float-register->fpr t))) + (if (fits-in-5-bits-signed? d) + (LAP (FLDDS () (OFFSET ,d 0 ,b) ,t)) + (LAP ,@(load-offset d b regnum:addil-result) + (FLDDS () (OFFSET 0 0 ,regnum:addil-result) ,t))))) + +(define (fp-store-doubleword r d b) + (let ((r (float-register->fpr r))) + (if (fits-in-5-bits-signed? d) + (LAP (FSTDS () ,r (OFFSET ,d 0 ,b))) + (LAP ,@(load-offset d b regnum:addil-result) + (FSTDS () ,r (OFFSET 0 0 ,regnum:addil-result)))))) + +(define (load-pc-relative label target) + ;; Load a pc-relative location's contents into a machine register. + ;; This assumes that the offset fits in 14 bits! + ;; We should have a pseudo-op for LDW that does some "branch" tensioning. + (LAP (BL () ,regnum:addil-result (@PCO 0)) + ;; Clear the privilege level, making this a memory address. + (DEP () 0 31 2 ,regnum:addil-result) + (LDW () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target))) + +(define (load-pc-relative-address label target) + ;; Load a pc-relative address into a machine register. + ;; This assumes that the offset fits in 14 bits! + ;; We should have a pseudo-op for LDO that does some "branch" tensioning. + (LAP (BL () ,regnum:addil-result (@PCO 0)) + ;; Clear the privilege level, making this a memory address. + (DEP () 0 31 2 ,regnum:addil-result) + (LDO () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target))) + +;; NOPs are inserted since conditional nullification only nullifies +;; depending on the sign of the branch offset, which is unknown at +;; this point. Linearizer can be changed, fairly easily, to tell us +;; which direction the branch goes so we can decide whether the NOP is +;; needed. + +(define (compare-immediate cc i r2) + (cond ((zero? i) + (compare cc 0 r2)) + ((fits-in-5-bits-signed? i) + (let* ((inverted? (memq cc '(TR <> >= > >>= >> NSV EV + LTGT GTEQ GT GTGTEQ GTGT))) + (cc (if inverted? (invert-condition cc) cc)) + (set-branches! + (lambda (if-true if-false) + (if inverted? + (set-current-branches! if-false if-true) + (set-current-branches! if-true if-false))))) + + (set-branches! + (lambda (label) + (LAP (COMIBT (,cc) ,i ,r2 (@PCR ,label)) + (NOP ()))) + (lambda (label) + (LAP (COMIBF (,cc) ,i ,r2 (@PCR ,label)) + (NOP ())))) + (LAP))) + ((fits-in-11-bits-signed? i) + (set-current-branches! + (lambda (label) + (LAP (COMICLR (,(invert-condition cc)) ,i ,r2 0) + (B (N) (@PCR ,label)))) + (lambda (label) + (LAP (COMICLR (,cc) ,i ,r2 0) + (B (N) (@PCR ,label))))) + (LAP)) + (else + (let ((temp (standard-temporary!))) + (LAP ,@(load-immediate i temp) + ,@(compare cc temp r2)))))) + +(define (compare condition r1 r2) + (set-current-branches! + (lambda (label) + (LAP (COMB (,condition) ,r1 ,r2 (@PCR ,label)) + (NOP ()))) + (lambda (label) + (LAP (COMB (,(invert-condition condition)) ,r1 ,r2 (@PCR ,label)) + (NOP ())))) + (LAP)) + +;;;; Conditions + +(define (invert-condition condition) + (let ((place (assq condition condition-inversion-table))) + (if (not place) + (error "unknown condition" condition)) + (cadr place))) + +(define (invert-condition-noncommutative condition) + (let ((place (assq condition condition-inversion-table))) + (if (not place) + (error "unknown condition" condition)) + (caddr place))) + +(define condition-inversion-table + '((= <> =) + (< >= >) + (> <= <) + (NUV UV NUV) + (TR NV TR) + (<< >>= >>) + (>> <<= <<) + (<> = <>) + (<= > >=) + (>= < <=) + (<<= >> >>=) + (>>= << <<=) + (NV TR NV) + (EQ LTGT EQ) + (LT GTEQ GT) + (SBZ NBZ SBZ) + (LTEQ GT GTEQ) + (SHZ NHZ SHZ) + (LTLT GTGTEQ GTGT) + (SDC NDC SDC) + (LTLTEQ GTGT GTGTEQ) + (ZNV VNZ ZNV) + (SV NSV SV) + (SBC NBC SBC) + (OD EV OD) + (SHC NHC SHC) + (LTGT EQ LTGT) + (GTEQ LT LTEQ) + (NBZ SBZ NBZ) + (GT LTEQ LT) + (NHZ SHZ NHZ) + (GTGTEQ LTLT LTLTEQ) + (UV NUV UV) + (NDC SDC NDC) + (GTGT LTLTEQ LTLT) + (VNZ ZNV NVZ) + (NSV SV NSV) + (NBC SBC NBC) + (EV OD EV) + (NHC SHC NHC))) + +;;;; Miscellaneous + +(define-integrable (object->datum src tgt) + (LAP (ZDEP () ,src 31 ,scheme-datum-width ,tgt))) + +(define-integrable (object->address reg) + (LAP (DEP () + ,regnum:quad-bitmask + ,(-1+ scheme-type-width) + ,scheme-type-width + ,reg))) + +(define-integrable (object->type src tgt) + (LAP (EXTRU () ,src ,(-1+ scheme-type-width) ,scheme-type-width ,tgt))) + +(define (standard-unary-conversion source target conversion) + ;; `source' is any register, `target' a pseudo register. + (let ((source (standard-source! source))) + (conversion source (standard-target! target)))) + +(define (standard-binary-conversion source1 source2 target conversion) + (let ((source1 (standard-source! source1)) + (source2 (standard-source! source2))) + (conversion source1 source2 (standard-target! target)))) + +(define (standard-source! register) + (load-alias-register! register (register-type register))) + +(define (standard-target! register) + (delete-dead-registers!) + (allocate-alias-register! register (register-type register))) + +(define-integrable (standard-temporary!) + (allocate-temporary-register! 'GENERAL)) + +(define (standard-move-to-target! source target) + (move-to-alias-register! source (register-type source) target)) + +(define (standard-move-to-temporary! source) + (move-to-temporary-register! source (register-type source))) + +(define (register-expression expression) + (case (rtl:expression-type expression) + ((REGISTER) + (rtl:register-number expression)) + ((CONSTANT) + (let ((object (rtl:constant-value expression))) + (and (zero? (object-type object)) + (zero? (object-datum object)) + 0))) + ((CONS-POINTER) + (and (let ((type (rtl:cons-pointer-type expression))) + (and (rtl:machine-constant? type) + (zero? (rtl:machine-constant-value type)))) + (let ((datum (rtl:cons-pointer-datum expression))) + (and (rtl:machine-constant? datum) + (zero? (rtl:machine-constant-value datum)))) + 0)) + (else false))) + +(define (define-arithmetic-method operator methods method) + (let ((entry (assq operator (cdr methods)))) + (if entry + (set-cdr! entry method) + (set-cdr! methods (cons (cons operator method) (cdr methods))))) + operator) -(define-integrable (machine-register->memory-post-increment source target) - ;; Used for heap allocation - `(STWM () ,source ,(index-reference target 1))) +(define (lookup-arithmetic-method operator methods) + (cdr (or (assq operator (cdr methods)) + (error "Unknown operator" operator)))) -(define-integrable (machine-register->memory-pre-decrement source target) - ;; Used for stack push - `(STWM () ,source ,(index-reference target -1))) +(define (fits-in-5-bits-signed? value) + (<= #x-10 value #xF)) -(define-integrable (memory->machine-register source target) - `(LDW () ,source ,target)) +(define (fits-in-11-bits-signed? value) + (<= #x-400 value #x3FF)) -(define-integrable (memory-post-increment->machine-register source target) - ;; Used for stack pop - `(LDWM () ,(index-reference source 1) ,target)) +(define (fits-in-14-bits-signed? value) + (<= #x-2000 value #x1FFF)) -(define-integrable (invoke-entry entry) - `(BE (N) ,entry)) +(define-integrable (ea/mode ea) (car ea)) +(define-integrable (register-ea/register ea) (cadr ea)) +(define-integrable (offset-ea/offset ea) (cadr ea)) +(define-integrable (offset-ea/space ea) (caddr ea)) +(define-integrable (offset-ea/register ea) (cadddr ea)) -(define (assign&invoke-entry number target entry) - (if (<= -8192 number 8191) - `((BE () ,entry) - (LDI () ,number ,target)) - `((LDIL () (LEFT ,number) ,target) - (BE () ,entry) - (LDO () (OFFSET (RIGHT ,number) ,target) ,target)))) +(define (pseudo-register-displacement register) + ;; Register block consists of 16 4-byte registers followed by 256 + ;; 8-byte temporaries. + (+ (* 4 16) (* 8 (register-renumber register)))) -(define (branch->label label) - `(BL (N) ,(label-relative-expression label) 0)) +(define-integrable (float-register->fpr register) + ;; Float registers are represented by 32 through 47 in the RTL, + ;; corresponding to registers 0 through 15 in the machine. + (- register 32)) -(define-integrable (index-reference register offset) - `(INDEX ,(* 4 offset) 0 ,(register-reference register))) +(define-integrable (fpr->float-register register) + (+ register 32)) -(define-integrable (offset-reference register offset) - `(OFFSET ,(* 4 offset) ,(register-reference register))) +(define-integrable reg:memtop + (INST-EA (OFFSET #x0000 0 ,regnum:regs-pointer))) -(define-integrable (short-offset? offset) - (< offset 2048)) +(define-integrable reg:environment + (INST-EA (OFFSET #x000C 0 ,regnum:regs-pointer))) -(define (load-memory source offset target) - `(LDW () ,(index-reference source offset) ,target)) +(define-integrable reg:lexpr-primitive-arity + (INST-EA (OFFSET #x001C 0 ,regnum:regs-pointer))) -(define (store-memory source target offset) - `(STW () ,source ,(index-reference target offset))) +(define (lap:make-label-statement label) + (INST (LABEL ,label))) -(define (load-memory-increment source offset target) - `(LDWM () ,(index-reference source offset) ,target)) +(define (lap:make-unconditional-branch label) + (INST (B (N) (@PCR ,label)))) -(define (store-memory-increment source target offset) - `(STWM () ,source ,(index-reference target offset))) - -;;;; Instruction Sequence Generators - -(define (indirect-reference! register offset) - (index-reference - (if (machine-register? register) - register - (or (register-alias register false) - ;; This means that someone has written an address out - ;; to memory, something that should never happen. - (error "Needed to load indirect register!" register))) - offset)) - -(define (object->address source #!optional target) - (if (unassigned? target) (set! target source)) - `((EXTRU () ,source 31 24 ,target) - (OR () ,regnum:address-offset ,target ,target))) - -(define (register->machine-register register target) - (if (machine-register? register) - (machine->machine-register register target) - (let ((alias (register-alias register false))) - (if alias - (machine->machine-register alias target) - (pseudo->machine-register register target))))) - -(define (expression->machine-register! expression register) - (let ((result - (case (car expression) - ((REGISTER) - `(,(register->machine-register (cadr expression) register))) - ((OFFSET) - `(,(memory->machine-register - (indirect-reference! (cadadr expression) (caddr expression)) - register))) - ((CONSTANT) - (scheme-constant->machine-register (cadr expression) register)) - (else (error "Bad expression type" (car expression)))))) - (delete-machine-register! register) - result)) - -(package (register->memory - register->memory-post-increment - register->memory-pre-decrement) - (define ((->memory machine-register->memory) register target) - `(,(machine-register->memory (guarantee-machine-register! register false) - target))) - (define-export register->memory - (->memory machine-register->memory)) - (define-export register->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export register->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(package (memory->memory - memory->memory-post-increment - memory->memory-pre-decrement) - (define ((->memory machine-register->memory) source target) - `(,(memory->machine-register source r1) - ,(machine-register->memory r1 target))) - (define-export memory->memory - (->memory machine-register->memory)) - (define-export memory->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export memory->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(package (memory-post-increment->memory - memory-post-increment->memory-post-increment - memory-post-increment->memory-pre-decrement) - (define ((->memory machine-register->memory) source target) - `(,(memory-post-increment->machine-register source r1) - ,(machine-register->memory r1 target))) - (define-export memory-post-increment->memory - (->memory machine-register->memory)) - (define-export memory-post-increment->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export memory-post-increment->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(package (scheme-constant->memory - scheme-constant->memory-post-increment - scheme-constant->memory-pre-decrement) - (define ((->memory machine-register->memory) constant target) - `(,@(scheme-constant->machine-register constant r1) - ,(machine-register->memory r1 target))) - (define-export scheme-constant->memory - (->memory machine-register->memory)) - (define-export scheme-constant->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export scheme-constant->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (scheme-constant->machine-register constant target) - (if (non-pointer-object? constant) - (non-pointer->machine-register (primitive-type constant) - (primitive-datum constant) - target) - `(,(memory->machine-register (scheme-constant-reference constant) - target)))) - -(define-integrable (scheme-constant-reference constant) - `(INDEX ,(label->machine-constant (constant->label constant)) - 0 - ,regnum:code-object-base)) - -(define (non-pointer->machine-register type datum target) - (if (and (zero? datum) - (deposit-type-constant? type)) - (if (zero? type) - `((OR () 0 0 ,target)) - (with-type-deposit-parameters type - (lambda (const end) - `((ZDEPI () ,const ,end 5 ,target))))) - (let ((number (make-non-pointer type datum))) - (if (<= -8192 number 8191) - `((LDI () ,number ,target)) - `((LDIL () (LEFT ,number) ,target) - (LDO () (OFFSET (RIGHT ,number) ,target) ,target)))))) - -(package (non-pointer->memory - non-pointer->memory-post-increment - non-pointer->memory-pre-decrement) - (define ((->memory machine-register->memory) constant target) - `(,@(non-pointer->machine-register constant r1) - ,(machine-register->memory r1 target))) - (define-export non-pointer->memory - (->memory machine-register->memory)) - (define-export non-pointer->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export non-pointer->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (machine-constant->machine-register constant target) - (non-pointer->machine-register (machine-constant->type constant) - (machine-constant->datum constant) - target)) - -(package (machine-constant->memory - machine-constant->memory-post-increment - machine-constant->memory-pre-decrement) - (define ((->memory machine-register->memory) constant target) - `(,@(machine-constant->machine-register constant r1) - ,(machine-register->memory r1 target))) - (define-export machine-constant->memory - (->memory machine-register->memory)) - (define-export machine-constant->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export machine-constant->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (label->machine-register label target) - (let ((constant (label->machine-constant label))) - `((ADDIL () (LEFT ,constant) ,regnum:code-object-base) - (LDO () (OFFSET (RIGHT ,constant) ,r1) ,target)))) - -(define-integrable (label->machine-constant label) - `(- ,label ,(code-object-base))) - -(package (label->memory - label->memory-post-increment - label->memory-pre-decrement) - (define ((->memory machine-register->memory) type label target) - (let ((temp (allocate-temporary-register! false))) - `(,@(label->machine-register type label temp) - ,(machine-register->memory temp target)))) - (define-export label->memory - (->memory machine-register->memory)) - (define-export label->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export label->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (typed-label->machine-register type label target) - `(,@(label->machine-register label target) - ,@(cons-pointer->machine-register type target target))) - -(package (typed-label->memory - typed-label->memory-post-increment - typed-label->memory-pre-decrement) - (define ((->memory machine-register->memory) type label target) - (let ((temp (allocate-temporary-register! false))) - `(,@(typed-label->machine-register type label temp) - ,(machine-register->memory temp target)))) - (define-export typed-label->memory - (->memory machine-register->memory)) - (define-export typed-label->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export typed-label->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) +(define (lap:make-entry-point label block-start-label) + block-start-label + (LAP (ENTRY-POINT ,label) + ,@(make-external-label expression-code-word label))) -(define (cons-pointer->machine-register type source target) - (let ((source (guarantee-machine-register! source false))) - (if (eqv? source target) - (let ((temp (allocate-temporary-register! false))) - `(,@(cons-pointer->machine-register type source temp) - ,(machine->machine-register temp source))) - `(,@(if (deposit-type-constant? type) - (with-type-deposit-parameters type - (lambda (type end) - `((ZDEPI () ,type ,end 5 ,target)))) - `((LDI () ,type ,target) - (ZDEP () ,target 7 8 ,target))) - (DEP () ,source 31 24 ,target))))) - -(package (cons-pointer->memory - cons-pointer->memory-post-increment - cons-pointer->memory-pre-decrement) - (define ((->memory machine-register->memory) type source target) - (let ((temp (allocate-temporary-register! false))) - `(,@(cons-pointer->machine-register type source temp) - ,(machine-register->memory temp target)))) - (define cons-pointer->memory - (->memory machine-register->memory)) - (define cons-pointer->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define cons-pointer->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (test:machine/machine-register condition source0 source1 receiver) - (let ((make-branch - (lambda (completer) - (lambda (label) - `((COMB (,completer N) ,source0 ,source1 - ,(label-relative-expression label))))))) - (receiver '() - (make-branch condition) - (make-branch (invert-test-completer condition))))) - -(define (test:short-machine-constant/machine-register condition constant source - receiver) - (let ((make-branch - (lambda (completer) - (lambda (label) - `((COMIB (,completer N) ,constant ,source - ,(label-relative-expression label))))))) - (receiver '() - (make-branch condition) - (make-branch (invert-test-completer condition))))) - -(define (invert-test-completer completer) - (cdr (or (assq completer - '((EQ . LTGT) (LTGT . EQ) - (LT . GTEQ) (GTEQ . LT) - (GT . LTEQ) (GT . LTEQ) - (LTLT . GTGTEQ) (GTGTEQ . LTLT) - (GTGT . LTLTEQ) (GTGT . LTLTEQ) - )) - (error "Unknown test completer" completer)))) - -(define (test:machine-constant/machine-register condition constant source - receiver) - (cond ((zero? constant) - (test:machine/machine-register condition 0 source receiver)) - ((test-short-constant? constant) - (test:short-machine-constant/machine-register condition constant - source receiver)) - (else - `(,@(non-pointer->machine-register 0 constant r1) - ,@(test:machine/machine-register condition r1 source receiver))))) - -(define (test:machine-constant/register condition constant source receiver) - (test:machine-constant/machine-register - condition constant (guarantee-machine-register! source false) receiver)) - -(define (test:machine-constant/memory condition constant source receiver) - (let ((temp (allocate-temporary-register! false))) - `(,(memory->machine-register source temp) - ,@(test:machine-constant/machine-register condition constant temp - receiver)))) - -(define (test:type/machine-register condition type source receiver) - (let ((temp (allocate-temporary-register! false))) - `(,(extract-type-machine->machine-register source temp) - ,@(test:machine-constant/machine-register condition type temp - receiver)))) - -(define (test:type/register condition type source receiver) - (test:type/machine-register condition type - (guarantee-machine-register! source false) - receiver)) - -(define (test:type/memory condition type source receiver) - (let ((temp (allocate-temporary-register! false))) - `(,(memory->machine-register source temp) - ,@(cond ((zero? type) - (test:machine/machine-register condition 0 temp receiver)) - ((test-short-constant? type) - `(,(extract-type-machine->machine-register temp temp) - ,@(test:short-machine-constant/machine-register condition - type - temp - receiver))) - (else - `(,@(non-pointer->machine-register 0 type r1) - ,(extract-type-machine->machine-register temp temp) - ,@(test:machine/machine-register condition r1 temp - receiver))))))) - -(define (standard-predicate-receiver prefix consequent alternative) - (set-current-branches! consequent alternative) - prefix) - -(define ((inline-predicate-receiver label) prefix consequent alternative) - `(,@prefix ,@(consequent label))) - -(define-integrable (extract-type-machine->machine-register source target) - `(EXTRU () ,source 7 8 ,target)) - -(define-integrable (test-short-constant? constant) - (<= -16 constant 15)) - -(define (deposit-type-constant? n) - ;; Assume that (<= 0 n 127). - (or (< n 16) - (zero? (remainder n - (cond ((< n 32) 2) - ((< n 64) 4) - (else 8)))))) - -(define (with-type-deposit-parameters type receiver) - ;; This one is for type codes, assume that (<= 0 n 127). - ;; Also assume that `(deposit-type-constant? type)' is true. - (cond ((< type 16) (receiver type 7)) - ((< type 32) (receiver (quotient type 2) 6)) - ((< type 64) (receiver (quotient type 4) 5)) - (else (receiver (quotient type 8) 4)))) - -(define (code-object-label-initialize code-object) - (cond ((procedure? code-object) false) - ((continuation? code-object) (continuation-label code-object)) - ((quotation? code-object) (quotation-label code-object)) - (else - (error "CODE-OBJECT-LABEL-INITIALIZE: Unknown code object type" - code-object)))) - -(define (code-object-base) - ;; This will fail if the difference between the beginning of the - ;; code-object and LABEL is greater than 11 bits (signed). - (or *code-object-label* - (let ((label (generate-label))) - (prefix-instructions! - `((BL () 0 ,regnum:code-object-base) - (LABEL ,label))) - (let ((label `(+ ,label 4))) - (set! *code-object-label* label) - label)))) - -(define (generate-n-times n limit prefix suffix with-counter) - (if (<= n limit) - (let loop ((n n)) - (if (zero? n) - '() - `(,@prefix - ,suffix - ,@(loop (-1+ n))))) - (let ((loop (generate-label 'LOOP))) - (with-counter - (lambda (counter) - `(,@(machine-constant->machine-register (-1+ n) counter) - (LABEL ,loop) - ,@prefix - (ADDIBF (EQ) -1 ,counter ,(label-relative-expression loop)) - ,suffix)))))) - -(define-integrable (label-relative-expression label) - `(- (- ,label *PC*) 8)) - -;;;; Registers/Entries +;;;; Codes and Hooks -(let-syntax ((define-entries - (macro names +(let-syntax ((define-codes + (macro (start . names) (define (loop names index) (if (null? names) '() - (cons `(DEFINE ,(symbol-append 'ENTRY:COMPILER- - (car names)) - `(INDEX ,,index 5 ,regnum:regs-pointer)) - (loop (cdr names) (+ index 8))))) - `(BEGIN ,@(loop names #x00F0))))) - (define-entries apply error wrong-number-of-arguments interrupt-procedure - interrupt-continuation lookup-apply lookup access unassigned? unbound? - set! define primitive-apply enclose setup-lexpr setup-ic-procedure)) - -(define reg:temp `(INDEX #x0010 0 ,regnum:regs-pointer)) -(define reg:compiled-memtop `(INDEX 0 0 ,regnum:regs-pointer)) - -(define popper:apply-closure `(INDEX 400 5 ,regnum:regs-pointer)) -(define popper:apply-stack `(INDEX 528 5 ,regnum:regs-pointer)) -(define popper:value `(INDEX 656 5 ,regnum:regs-pointer)) - -(package (type->machine-constant - make-non-pointer - machine-constant->type - machine-constant->datum) - (define type-scale-factor - (expt 2 24)) - (define-export (type->machine-constant type) - (* type type-scale-factor)) - (define-export (make-non-pointer type datum) - (+ (* type type-scale-factor) datum)) - (define-export (machine-constant->type constant) - (quotient constant type-scale-factor)) - (define-export (machine-constant->datum constant) - (remainder constant type-scale-factor))) - -(define constant:compiled-expression - (type->machine-constant (ucode-type compiled-expression))) - -(define constant:return-address - (type->machine-constant (ucode-type return-address))) - -(define constant:unassigned - (make-non-pointer (ucode-type unassigned) 0)) - -(define constant:false - (make-non-pointer (ucode-type false) 0)) - -;;;; Transfers to Registers - -;;; All assignments to pseudo registers are required to delete the -;;; dead registers BEFORE performing the assignment. This is because -;;; the register being assigned may be PSEUDO-REGISTER=? to one of the -;;; dead registers, and thus would be flushed if the deletions -;;; happened after the assignment. - -(define-rule statement - (ASSIGN (REGISTER 30) (OFFSET-ADDRESS (REGISTER 30) (? n))) - `((LDO () ,(offset-reference regnum:stack-pointer n) ,r30))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) - (QUALIFIER (pseudo-register? target)) - (scheme-constant->machine-register source - (allocate-assignment-alias! target - false))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (REGISTER (? source))) - (QUALIFIER (pseudo-register? target)) - (move-to-alias-register! source false target) - '()) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (object->address (move-to-alias-register! source false target))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (let ((target (move-to-alias-register! source false target))) - `(,(extract-type-machine->machine-register target target)))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) - (QUALIFIER (and (pseudo-register? target) (short-offset? offset))) - (let ((source (indirect-reference! address offset))) ;force eval order. - `(,(memory->machine-register source - (allocate-assignment-alias! target false))))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? source)) 1)) - (QUALIFIER (pseudo-register? target)) - (memory-post-increment->machine-register - source - (allocate-assignment-alias! target false))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) - (QUALIFIER (pseudo-register? target)) - (cons-pointer->machine-register type datum - (allocate-assignment-alias! target false))) - -;;;; Transfers to Memory - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (CONSTANT (? object))) - (QUALIFIER (short-offset? n)) - (scheme-constant->memory object (indirect-reference! a n))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (REGISTER (? r))) - (QUALIFIER (short-offset? n)) - (register->memory r (indirect-reference! a n))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (POINTER-INCREMENT (REGISTER (? source)) 1)) - (QUALIFIER (short-offset? n)) - (memory-post-increment->memory source (indirect-reference! a n))) - -(define-rule statement - ;; The code assumes r cannot be trashed - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) - (QUALIFIER (short-offset? n)) - (cons-pointer->memory type r (indirect-reference! a n))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? r-target)) (? n-target)) - (OFFSET (REGISTER (? r-source)) (? n-source))) - (QUALIFIER (and (short-offset? n-target) (short-offset? n-source))) - (memory->memory (indirect-reference! r-source n-source) - (indirect-reference! r-target n-target))) - -;;;; Consing - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (CONSTANT (? object))) - (scheme-constant->memory-post-increment object r25)) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (REGISTER (? r))) - (register->memory-post-increment r r25)) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (OFFSET (REGISTER (? r)) (? n))) - (memory->memory-post-increment (indirect-reference! r n) r25)) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (ENTRY:PROCEDURE (? procedure))) - (typed-label->memory-post-increment (ucode-type compiled-expression) - (procedure-external-label procedure) - r25)) - -;;;; Pushes - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (CONSTANT (? object))) - (scheme-constant->memory-pre-decrement object r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (UNASSIGNED)) - (scheme-constant->memory-pre-decrement constant:unassigned r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (REGISTER (? r))) - (register->memory-pre-decrement r r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) - (cons-pointer->memory-pre-decrement type r r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (OFFSET (REGISTER (? r)) (? n))) - (QUALIFIER (short-offset? n)) - (memory->memory-pre-decrement (indirect-reference! r n) r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) - (OFFSET-ADDRESS (REGISTER 30) (? n))) - (QUALIFIER (short-offset? n)) - (let ((temp (allocate-temporary-register! false))) - `((LDI () ,(ucode-type stack-environment) ,temp) - (LDO () ,(offset-reference r30 n) ,r1) - (DEP () ,temp 7 8 ,r1) - ,@(register->memory-pre-decrement r1 r30)))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) - (ENTRY:CONTINUATION (? continuation))) - (typed-label->memory-pre-decrement (ucode-type return-address) - (continuation-label continuation) - r30)) - -;;;; Predicates - -(define-rule predicate - (TRUE-TEST (REGISTER (? register))) - (test:machine-constant/register 'LTGT constant:false register - standard-predicate-receiver)) - -(define-rule predicate - (TRUE-TEST (OFFSET (REGISTER (? register)) (? offset))) - (test:machine-constant/memory 'LTGT constant:false - (indirect-reference! register offset) - standard-predicate-receiver)) - -(define-rule predicate - (TYPE-TEST (REGISTER (? register)) (? type)) - (test:machine-constant/machine-register 'LTGT type register - standard-predicate-receiver)) - -(define-rule predicate - (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type)) - (test:type/register 'LTGT type register standard-predicate-receiver)) - -(define-rule predicate - (UNASSIGNED-TEST (REGISTER (? register))) - (test:machine-constant/register 'LTGT constant:unassigned register - standard-predicate-receiver)) - -(define-rule predicate - (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset))) - (test:machine-constant/memory 'LTGT constant:unassigned - (indirect-reference! register offset) - standard-predicate-receiver)) - -;;;; Invocations - -(define-rule statement - (INVOCATION:APPLY (? number-pushed) (? prefix) (? continuation)) - `(,@(generate-invocation-prefix prefix) - ,@(assign&invoke-entry number-pushed regnum:frame-size - entry:compiler-apply))) - -(define-rule statement - (INVOCATION:JUMP (? n) - (APPLY-CLOSURE (? frame-size) (? receiver-offset)) - (? continuation) (? procedure)) - `(,@(clear-map!) - ,@(apply-closure-sequence frame-size receiver-offset - (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:JUMP (? n) - (APPLY-STACK (? frame-size) (? receiver-offset) - (? n-levels)) - (? continuation) (? procedure)) - `(,@(clear-map!) - ,@(apply-stack-sequence frame-size receiver-offset n-levels - (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:JUMP (? number-pushed) (? prefix) (? continuation) (? procedure)) - (QUALIFIER (not (memq (car prefix) '(APPLY-CLOSURE APPLY-STACK)))) - `(,@(generate-invocation-prefix prefix) - ,(branch->label (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation) - (? procedure)) - `(,@(generate-invocation-prefix prefix) - ,@(machine-constant->machine-register number-pushed regnum:frame-size) - ,(branch->label (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:LOOKUP (? number-pushed) (? prefix) (? continuation) - (? environment) (? name)) - (let ((set-environment - (expression->machine-register! environment regnum:call-argument-0))) - (delete-dead-registers!) - `(,@set-environment - ,@(generate-invocation-prefix prefix) - ,@(scheme-constant->machine-register name regnum:call-argument-1) - ,@(assign&invoke-entry (1+ number-pushed) regnum:frame-size - entry:compiler-lookup-apply)))) - -(define-rule statement - (INVOCATION:PRIMITIVE (? number-pushed) (? prefix) (? continuation) - (? primitive)) - `(,@(generate-invocation-prefix prefix) - ,@(if (eq? primitive compiled-error-procedure) - (assign&invoke-entry number-pushed regnum:frame-size - entry:compiler-error) - ;; Simple thing for now. - (assign&invoke-entry (primitive-datum primitive) - regnum:call-argument-0 - entry:compiler-primitive-apply)))) - -(define-rule statement - (RETURN) - `(,@(clear-map!) - ,(memory-post-increment->machine-register regnum:stack-pointer - regnum:code-object-base) - ,@(object->address regnum:code-object-base) - (BE (N) (INDEX 0 1 ,regnum:code-object-base)))) - -(define (generate-invocation-prefix prefix) - `(,@(clear-map!) - ,@(case (car prefix) - ((NULL) '()) - ((MOVE-FRAME-UP) - (apply generate-invocation-prefix:move-frame-up (cdr prefix))) - ((APPLY-CLOSURE) - (apply generate-invocation-prefix:apply-closure (cdr prefix))) - ((APPLY-STACK) - (apply generate-invocation-prefix:apply-stack (cdr prefix))) - (else (error "GENERATE-INVOCATION-PREFIX: bad prefix type" prefix))))) - -(define (generate-invocation-prefix:move-frame-up frame-size how-far) - (cond ((or (zero? frame-size) (zero? how-far)) '()) - ((= frame-size 1) - `(,(load-memory-increment regnum:stack-pointer (+ frame-size how-far) - r1) - ,(store-memory r1 regnum:stack-pointer 0))) - ((= frame-size 2) - (let ((temp (allocate-temporary-register! false))) - `(,(load-memory-increment regnum:stack-pointer 1 r1) - ,(load-memory-increment regnum:stack-pointer (-1+ how-far) temp) - ,(store-memory r1 regnum:stack-pointer 0) - ,(store-memory temp regnum:stack-pointer 1)))) - (else - (let ((temp0 (allocate-temporary-register! false)) - (temp1 (allocate-temporary-register! false))) - `((LDO () - ,(offset-reference regnum:stack-pointer frame-size) - ,temp0) - (LDO () - ,(offset-reference regnum:stack-pointer - (+ frame-size how-far)) - ,temp1) - ,@(generate-n-times - frame-size 5 - `(,(load-memory-increment temp0 -1 r1)) - (store-memory-increment r1 temp1 -1) - (lambda (generator) - (generator (allocate-temporary-register! false)))) - ,(machine->machine-register temp1 regnum:stack-pointer)))))) - -(define (generate-invocation-prefix:apply-closure frame-size receiver-offset) - (let ((label (generate-label))) - `(,@(apply-closure-sequence frame-size receiver-offset label) - (LABEL ,label)))) - -(define (generate-invocation-prefix:apply-stack frame-size receiver-offset - n-levels) - (let ((label (generate-label))) - `(,@(apply-stack-sequence frame-size receiver-offset n-levels label) - (LABEL ,label)))) - -;;;; Environment Calls - -(define-rule statement - (INTERPRETER-CALL:ACCESS (? environment) (? name)) - (lookup-call entry:compiler-access environment name)) - -(define-rule statement - (INTERPRETER-CALL:LOOKUP (? environment) (? name)) - (lookup-call entry:compiler-lookup environment name)) - -(define-rule statement - (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name)) - (lookup-call entry:compiler-unassigned? environment name)) - -(define-rule statement - (INTERPRETER-CALL:UNBOUND? (? environment) (? name)) - (lookup-call entry:compiler-unbound? environment name)) - -(define (lookup-call entry environment name) - (let ((set-environment - (expression->machine-register! environment regnum:call-argument-0))) - (let ((clear-map (clear-map!))) - `(,@set-environment - ,@clear-map - ,(scheme-constant->machine-register name regnum:argument-1) - (BLE (N) ,entry) - ,@(make-external-label (generate-label)))))) - -(define-rule statement - (INTERPRETER-CALL:ENCLOSE (? number-pushed)) - `(,@(cons-pointer->machine-register (ucode-type vector) regnum:free-pointer - regnum:call-value) - ,@(non-pointer->memory-post-increment (ucode-type manifest-vector) - number-pushed - regnum:free-pointer) - ,@(generate-n-times number-pushed 5 - `(,(load-memory-increment regnum:stack-pointer 1 r1)) - (store-memory-increment r1 regnum:free-pointer 1) - (lambda (generator) - (generator (allocate-temporary-register! false)))))) - -(define-rule statement - (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value)) - (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (assignment-call:default entry:compiler-define environment name value)) - -(define-rule statement - (INTERPRETER-CALL:SET! (? environment) (? name) (? value)) - (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (assignment-call:default entry:compiler-set! environment name value)) - -(define (assignment-call:default entry environment name value) - (let ((set-environment - (expression->machine-register! environment regnum:call-argument-0))) - (let ((set-value - (expression->machine-register! value regnum:call-argument-2))) - (let ((clear-map (clear-map!))) - `(,@set-environment - ,@set-value - ,@clear-map - ,@(scheme-constant->machine-register name regnum:call-argument-1) - (BLE (N) ,entry) - ,@(make-external-label (generate-label))))))) - -(define-rule statement - (INTERPRETER-CALL:DEFINE (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (REGISTER (? datum)))) - (assignment-call:cons-pointer entry:compiler-define environment name type - datum)) - -(define-rule statement - (INTERPRETER-CALL:SET! (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (REGISTER (? datum)))) - (assignment-call:cons-pointer entry:compiler-set! environment name type - datum)) - -(define (assignment-call:cons-pointer entry environment name type datum) - (let ((set-environment - (expression->machine-register! environment regnum:call-argument-0))) - (let ((set-value - (cons-pointer->machine-register type datum regnum:call-argument-2))) - (let ((clear-map (clear-map!))) - `(,@set-environment - ,@set-value - ,@clear-map - ,@(scheme-constant->machine-register name regnum:call-argument-1) - (BLE (N) ,entry) - ,@(make-external-label (generate-label))))))) - -;;;; Procedure/Continuation Entries - -;;; The following calls MUST appear as the first thing at the entry -;;; point of a procedure. They assume that the register map is clear -;;; and that no register contains anything of value. - -;;; **** The only reason that this is true is that no register is live -;;; across calls. If that were not true, then we would have to save -;;; any such registers on the stack so that they would be GC'ed -;;; appropriately. - -(define-rule statement - (PROCEDURE-HEAP-CHECK (? procedure)) - (let ((label (generate-label))) - `(,@(procedure-header procedure) - (COMBT (LT N) ,regnum:free-pointer ,regnum:memtop-pointer - ,(label-relative-expression label)) - (BLE (N) ,entry:compiler-interrupt-procedure) - (LABEL ,label)))) - -(define-rule statement - (CONTINUATION-HEAP-CHECK (? continuation)) - (let ((label (generate-label))) - `(,@(make-external-label (continuation-label continuation)) - (COMBT (LT N) ,regnum:free-pointer ,regnum:memtop-pointer - ,(label-relative-expression label)) - (BLE (N) ,entry:compiler-interrupt-procedure) - (LABEL ,label)))) - -(define (procedure-header procedure) - (let ((internal-label (procedure-label procedure))) - (append! (if (procedure/closure? procedure) - (let ((required (1+ (length (procedure-required procedure)))) - (optional (length (procedure-optional procedure))) - (label (procedure-external-label procedure))) - (if (and (procedure-rest procedure) - (zero? required)) - (begin (set-procedure-external-label! procedure - internal-label) - `((ENTRY-POINT ,internal-label))) - `((ENTRY-POINT ,label) - ,@(make-external-label label) - ,@(cond ((procedure-rest procedure) - (test:machine-constant/machine-register - 'GTEQ required regnum:frame-size - (inline-predicate-receiver internal-label))) - ((zero? optional) - (test:machine-constant/machine-register - 'EQ required regnum:frame-size - (inline-predicate-receiver internal-label))) - (else - (let ((wna-label (generate-label))) - `(,@(test:machine-constant/machine-register - 'LT required regnum:frame-size - (inline-predicate-receiver wna-label)) - ,@(test:machine-constant/machine-register - 'LTEQ (+ required optional) - regnum:frame-size - (inline-predicate-receiver - internal-label)) - (LABEL ,wna-label))))) - ,(invoke-entry - entry:compiler-wrong-number-of-arguments)))) - '()) - `(,@(make-external-label internal-label))))) - -(define *block-start-label*) - -(define (make-external-label label) - `((WORD (- ,label ,*block-start-label*)) - (LABEL ,label))) - -;;;; Poppers - -(define-rule statement - (MESSAGE-RECEIVER:CLOSURE (? frame-size)) - (machine-constant->memory-pre-decrement (* frame-size 4) r30)) - -(define-rule statement - (MESSAGE-RECEIVER:STACK (? frame-size)) - (machine-constant->memory-pre-decrement (+ #x00200000 (* frame-size 4)) - r30)) - -(define-rule statement - (MESSAGE-RECEIVER:SUBPROBLEM (? continuation)) - `(,@(typed-label->memory-pre-decrement (ucode-type return-address) - (continuation-label continuation) - r30) - ,@(machine-constant->memory-pre-decrement #x00400000 r30))) - -(define (apply-closure-sequence frame-size receiver-offset label) - `(,@(machine-constant->machine-register (* frame-size 4) r19) - (LDO () ,(offset-reference r30 (* receiver-offset 4)) ,r20) - ,@(label->machine-register label r21) - (BLE (N) ,popper:apply-closure))) - -(define (apply-stack-sequence frame-size receiver-offset n-levels label) - `(,@(machine-constant->machine-register (* frame-size 4) r19) - (LDO () ,(offset-reference r30 (* receiver-offset 4)) ,r20) - ,@(label->machine-register label r21) - ,@(machine-constant->machine-register n-levels r22) - (BLE (N) ,popper:apply-stack))) - -(define-rule statement - (MESSAGE-SENDER:VALUE (? receiver-offset)) - `(,@(clear-map!) - (LDO () ,(offset-reference r30 (* receiver-offset 4)) ,r30) - (BLE (N) ,popper:value))) \ No newline at end of file + (cons `(DEFINE-INTEGRABLE + ,(symbol-append 'CODE:COMPILER- + (car names)) + ,index) + (loop (cdr names) (1+ index))))) + `(BEGIN ,@(loop names start))))) + (define-codes #x012 + primitive-apply primitive-lexpr-apply + apply error lexpr-apply link + interrupt-closure interrupt-dlink interrupt-procedure + interrupt-continuation interrupt-ic-procedure + assignment-trap cache-reference-apply + reference-trap safe-reference-trap unassigned?-trap + -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero? + access lookup safe-lookup unassigned? unbound? + set! define lookup-apply)) + +(define-integrable (invoke-interface-ble code) + ;; Jump to scheme-to-interface-ble + (LAP (BLE () (OFFSET 0 4 ,regnum:scheme-to-interface-ble)) + (LDI () ,code 28))) + +;;; trampoline-to-interface uses (OFFSET 4 4 ,regnum:scheme-to-interface-ble) + +(define-integrable (invoke-interface code) + ;; Jump to scheme-to-interface + (LAP (BLE () (OFFSET 12 4 ,regnum:scheme-to-interface-ble)) + (LDI () ,code 28))) + +(let-syntax ((define-hooks + (macro (start . names) + (define (loop names index) + (if (null? names) + '() + (cons `(DEFINE-INTEGRABLE + ,(symbol-append 'HOOK:COMPILER- + (car names)) + ,index) + (loop (cdr names) (+ 8 index))))) + `(BEGIN ,@(loop names start))))) + (define-hooks 100 + store-closure-code)) + +(define (load-interface-args! first second third fourth) + (let ((clear-regs + (apply clear-registers! + (append (if first (list first) '()) + (if second (list second) '()) + (if third (list third) '()) + (if fourth (list fourth) '())))) + (load-reg + (lambda (reg arg) + (if reg (load-machine-register! reg arg) (LAP))))) + (let ((load-regs + (LAP ,@(load-reg first regnum:first-arg) + ,@(load-reg second regnum:second-arg) + ,@(load-reg third regnum:third-arg) + ,@(load-reg fourth regnum:fourth-arg)))) + (LAP ,@clear-regs + ,@load-regs + ,@(clear-map!))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/machin.scm b/v7/src/compiler/machines/spectrum/machin.scm index ac31a85c6..d74e0ea06 100644 --- a/v7/src/compiler/machines/spectrum/machin.scm +++ b/v7/src/compiler/machines/spectrum/machin.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/machin.scm,v 1.41 1987/03/19 00:55:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/machin.scm,v 4.20 1990/01/25 16:27:42 jinx Exp $ +$MC68020-Header: machin.scm,v 4.20 90/01/18 22:43:44 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,152 +33,290 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Machine Model for Spectrum +;;; Machine Model for Spectrum (declare (usual-integrations)) -(define (rtl:message-receiver-size:closure) 1) -(define (rtl:message-receiver-size:stack) 1) -(define (rtl:message-receiver-size:subproblem) 1) +;;;; Architecture Parameters -(define-integrable (stack->memory-offset offset) - offset) +(define-integrable endianness 'BIG) +(define-integrable addressing-granularity 8) +(define-integrable scheme-object-width 32) +(define-integrable scheme-type-width 6) ;or 8 -(define (rtl:expression-cost expression) - ;; Returns an estimate of the cost of evaluating the expression. - ;; For time being, disable this feature. - 1) +(define-integrable scheme-datum-width + (- scheme-object-width scheme-type-width)) -(define (rtl:machine-register? rtl-register) - (case rtl-register - ((STACK-POINTER) (interpreter-stack-pointer)) - ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) - ((INTERPRETER-CALL-RESULT:ENCLOSE) (interpreter-register:enclose)) - ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup)) - ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?)) - ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?)) - (else false))) +(define-integrable type-scale-factor + (expt 2 (- 8 scheme-type-width))) -(define (rtl:interpreter-register? rtl-register) - (case rtl-register - ((MEMORY_TOP) 0) - ((STACK_GUARD) 1) - ((VALUE) 2) - ((ENVIRONMENT) 3) - ((TEMPORARY) 4) - (else false))) +(define-integrable flonum-size 2) +(define-integrable float-alignment 64) -(define (rtl:interpreter-register->offset locative) - (or (rtl:interpreter-register? locative) - (error "Unknown register type" locative))) - -(define-integrable r0 0) -(define-integrable r1 1) -(define-integrable r2 2) -(define-integrable r3 3) -(define-integrable r4 4) -(define-integrable r5 5) -(define-integrable r6 6) -(define-integrable r7 7) -(define-integrable r8 8) -(define-integrable r9 9) -(define-integrable r10 10) -(define-integrable r11 11) -(define-integrable r12 12) -(define-integrable r13 13) -(define-integrable r14 14) -(define-integrable r15 15) -(define-integrable r16 16) -(define-integrable r17 17) -(define-integrable r18 18) -(define-integrable r19 19) -(define-integrable r20 20) -(define-integrable r21 21) -(define-integrable r22 22) -(define-integrable r23 23) -(define-integrable r24 24) -(define-integrable r25 25) -(define-integrable r26 26) -(define-integrable r27 27) -(define-integrable r28 28) -(define-integrable r29 29) -(define-integrable r30 30) -(define-integrable r31 31) - -(define number-of-machine-registers 32) - -(define-integrable (sort-machine-registers registers) - registers) - -(define (pseudo-register=? x y) - (= (register-renumber x) (register-renumber y))) - -(define available-machine-registers - (list r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 r14 r15 r16 r17 r18 - r19 r20 r21 r22)) - -(define-integrable (register-contains-address? register) - (memv register '(23 24 25 30))) - -(define-integrable (register-type register) - false) +;;; It is currently required that both packed characters and objects +;;; be integrable numbers of address units. Furthermore, the number +;;; of address units per object must be an integral multiple of the +;;; number of address units per character. This will cause problems +;;; on a machine that is word addressed, in which case we will have to +;;; rethink the character addressing strategy. -(define-integrable (register-reference register) - register) - -(define-integrable regnum:frame-size r3) -(define-integrable regnum:call-argument-0 r4) -(define-integrable regnum:call-argument-1 r5) -(define-integrable regnum:call-argument-2 r6) -(define-integrable regnum:call-value r28) - -(define-integrable regnum:memtop-pointer r23) -(define-integrable regnum:regs-pointer r24) -(define-integrable regnum:free-pointer r25) -(define-integrable regnum:code-object-base r26) -(define-integrable regnum:address-offset r27) -(define-integrable regnum:stack-pointer r30) +(define-integrable address-units-per-object + (quotient scheme-object-width addressing-granularity)) -(define-integrable (interpreter-register:access) - (rtl:make-machine-register regnum:call-value)) - -(define-integrable (interpreter-register:enclose) - (rtl:make-machine-register regnum:call-value)) +(define-integrable address-units-per-packed-char 1) -(define-integrable (interpreter-register:lookup) - (rtl:make-machine-register regnum:call-value)) +(define-integrable signed-fixnum/upper-limit (expt 2 (-1+ scheme-datum-width))) +(define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit)) +(define-integrable unsigned-fixnum/upper-limit (* 2 signed-fixnum/upper-limit)) -(define-integrable (interpreter-register:unassigned?) - (rtl:make-machine-register regnum:call-value)) - -(define-integrable (interpreter-register:unbound?) - (rtl:make-machine-register regnum:call-value)) +(define-integrable (stack->memory-offset offset) offset) +(define-integrable ic-block-first-parameter-offset 2) +(define-integrable closure-block-first-offset 3) + +;;;; Machine Registers + +(define-integrable g0 0) +(define-integrable g1 1) +(define-integrable g2 2) +(define-integrable g3 3) +(define-integrable g4 4) +(define-integrable g5 5) +(define-integrable g6 6) +(define-integrable g7 7) +(define-integrable g8 8) +(define-integrable g9 9) +(define-integrable g10 10) +(define-integrable g11 11) +(define-integrable g12 12) +(define-integrable g13 13) +(define-integrable g14 14) +(define-integrable g15 15) +(define-integrable g16 16) +(define-integrable g17 17) +(define-integrable g18 18) +(define-integrable g19 19) +(define-integrable g20 20) +(define-integrable g21 21) +(define-integrable g22 22) +(define-integrable g23 23) +(define-integrable g24 24) +(define-integrable g25 25) +(define-integrable g26 26) +(define-integrable g27 27) +(define-integrable g28 28) +(define-integrable g29 29) +(define-integrable g30 30) +(define-integrable g31 31) + +;; fp0 - fp3 are status registers. The rest are real registers +(define-integrable fp0 32) +(define-integrable fp1 33) +(define-integrable fp2 34) +(define-integrable fp3 35) +(define-integrable fp4 36) +(define-integrable fp5 37) +(define-integrable fp6 38) +(define-integrable fp7 39) +(define-integrable fp8 40) +(define-integrable fp9 41) +(define-integrable fp10 42) +(define-integrable fp11 43) +(define-integrable fp12 44) +(define-integrable fp13 45) +(define-integrable fp14 46) +(define-integrable fp15 47) + +(define-integrable number-of-machine-registers 48) +(define-integrable number-of-temporary-registers 256) + +;;; Fixed-use registers for Scheme compiled code. +(define-integrable regnum:return-value g2) +(define-integrable regnum:scheme-to-interface-ble g3) +(define-integrable regnum:regs-pointer g4) +(define-integrable regnum:quad-bitmask g5) +(define-integrable regnum:dynamic-link g19) +(define-integrable regnum:memtop-pointer g20) +(define-integrable regnum:free-pointer g21) +(define-integrable regnum:stack-pointer g22) + +;;; Fixed-use registers due to architecture or OS calling conventions. +(define-integrable regnum:zero g0) +(define-integrable regnum:addil-result g1) +(define-integrable regnum:C-global-pointer g27) +(define-integrable regnum:C-return-value g28) +(define-integrable regnum:C-stack-pointer g30) +(define-integrable regnum:ble-return g31) +(define-integrable regnum:fourth-arg g23) +(define-integrable regnum:third-arg g24) +(define-integrable regnum:second-arg g25) +(define-integrable regnum:first-arg g26) + +(define (machine-register-value-class register) + (cond ((or (= register 0) + (<= 6 register 18) + (<= 23 register 26) + (= register 29) + (= register 31)) + value-class=word) + ((or (= register 2) (= register 28)) + value-class=object) + ((or (= register 1) (= register 3)) + value-class=unboxed) + ((or (= register 4) + (<= 19 register 22) + (= register 27) + (= register 30)) + value-class=address) + ((= register 5) + value-class=immediate) + ((<= 32 register 47) + value-class=float) + (else + (error "illegal machine register" register)))) + +(define-integrable (machine-register-known-value register) + register ;ignore + false) + +;;;; Interpreter Registers (define-integrable (interpreter-free-pointer) (rtl:make-machine-register regnum:free-pointer)) -(define-integrable (interpreter-free-pointer? register) - (= (rtl:register-number register) regnum:free-pointer)) +(define (interpreter-free-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:free-pointer))) (define-integrable (interpreter-regs-pointer) (rtl:make-machine-register regnum:regs-pointer)) -(define-integrable (interpreter-regs-pointer? register) - (= (rtl:register-number register) regnum:regs-pointer)) +(define (interpreter-regs-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:regs-pointer))) + +(define-integrable (interpreter-value-register) + (rtl:make-machine-register regnum:return-value)) + +(define (interpreter-value-register? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:return-value))) (define-integrable (interpreter-stack-pointer) (rtl:make-machine-register regnum:stack-pointer)) -(define-integrable (interpreter-stack-pointer? register) - (= (rtl:register-number register) regnum:stack-pointer)) +(define (interpreter-stack-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:stack-pointer))) + +(define-integrable (interpreter-dynamic-link) + (rtl:make-machine-register regnum:dynamic-link)) + +(define (interpreter-dynamic-link? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:dynamic-link))) + +(define-integrable (interpreter-environment-register) + (rtl:make-offset (interpreter-regs-pointer) 3)) + +(define (interpreter-environment-register? expression) + (and (rtl:offset? expression) + (interpreter-regs-pointer? (rtl:offset-base expression)) + (= 3 (rtl:offset-number expression)))) + +(define-integrable (interpreter-register:access) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:cache-reference) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:cache-unassigned?) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:lookup) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:unassigned?) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:unbound?) + (rtl:make-machine-register g28)) -(define (lap:make-label-statement label) - `(LABEL ,label)) +;;;; RTL Registers, Constants, and Primitives -(define (lap:make-unconditional-branch label) - `((BL (N) (- (- ,label *PC*) 8) 0))) +(define (rtl:machine-register? rtl-register) + (case rtl-register + ((STACK-POINTER) + (interpreter-stack-pointer)) + ((DYNAMIC-LINK) + (interpreter-dynamic-link)) + ((VALUE) + (interpreter-value-register)) + ((INTERPRETER-CALL-RESULT:ACCESS) + (interpreter-register:access)) + ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) + (interpreter-register:cache-reference)) + ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) + (interpreter-register:cache-unassigned?)) + ((INTERPRETER-CALL-RESULT:LOOKUP) + (interpreter-register:lookup)) + ((INTERPRETER-CALL-RESULT:UNASSIGNED?) + (interpreter-register:unassigned?)) + ((INTERPRETER-CALL-RESULT:UNBOUND?) + (interpreter-register:unbound?)) + (else false))) + +(define (rtl:interpreter-register? rtl-register) + (case rtl-register + ((MEMORY-TOP) 0) + ((STACK-GUARD) 1) + ((ENVIRONMENT) 3) + ((TEMPORARY) 4) + (else false))) + +(define (rtl:interpreter-register->offset locative) + (or (rtl:interpreter-register? locative) + (error "Unknown register type" locative))) -(define (lap:make-entry-point label block-start-label) - `((ENTRY-POINT ,label) - (WORD (- ,label ,block-start-label)) - (LABEL ,label))) \ No newline at end of file +(define (rtl:constant-cost expression) + ;; Magic numbers. + (let ((if-integer + (lambda (value) + (cond ((zero? value) 1) + ((fits-in-5-bits-signed? value) 2) + (else 3))))) + (let ((if-synthesized-constant + (lambda (type datum) + (if-integer (make-non-pointer-literal type datum))))) + (case (rtl:expression-type expression) + ((CONSTANT) + (let ((value (rtl:constant-value expression))) + (if (non-pointer-object? value) + (if-synthesized-constant (object-type value) + (object-datum value)) + 3))) + ((MACHINE-CONSTANT) + (if-integer (rtl:machine-constant-value expression))) + ((ENTRY:PROCEDURE + ENTRY:CONTINUATION + ASSIGNMENT-CACHE + VARIABLE-CACHE + OFFSET-ADDRESS) + 3) + ((CONS-POINTER) + (and (rtl:machine-constant? (rtl:cons-pointer-type expression)) + (rtl:machine-constant? (rtl:cons-pointer-datum expression)) + (if-synthesized-constant + (rtl:machine-constant-value (rtl:cons-pointer-type expression)) + (rtl:machine-constant-value + (rtl:cons-pointer-datum expression))))) + (else false))))) + +(define compiler:open-code-floating-point-arithmetic? + true) + +(define compiler:primitives-with-no-open-coding + '(MULTIPLY-FIXNUM INTEGER-MULTIPLY &* + DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER + INTEGER-QUOTIENT INTEGER-REMAINDER &/ + FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS + FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE)) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/rgspcm.scm b/v7/src/compiler/machines/spectrum/rgspcm.scm new file mode 100644 index 000000000..d0b56e8cd --- /dev/null +++ b/v7/src/compiler/machines/spectrum/rgspcm.scm @@ -0,0 +1,75 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rgspcm.scm,v 4.1 1990/01/25 16:39:03 jinx Rel $ +$MC68020-Header: rgspcm.scm,v 4.1 87/12/30 07:05:38 GMT cph Exp $ + +Copyright (c) 1987, 1989, 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. |# + +;;;; RTL Generation: Special primitive combinations. Spectrum version. + +(declare (usual-integrations)) + +(define (define-special-primitive-handler name handler) + (let ((primitive (make-primitive-procedure name true))) + (let ((entry (assq primitive special-primitive-handlers))) + (if entry + (set-cdr! entry handler) + (set! special-primitive-handlers + (cons (cons primitive handler) + special-primitive-handlers))))) + name) + +(define (special-primitive-handler primitive) + (let ((entry (assq primitive special-primitive-handlers))) + (and entry + (cdr entry)))) + +(define special-primitive-handlers + '()) + +(define (define-special-primitive/standard primitive) + (define-special-primitive-handler primitive + rtl:make-invocation:special-primitive)) + +(define-special-primitive/standard '&+) +(define-special-primitive/standard '&-) +;; (define-special-primitive/standard '&*) +(define-special-primitive/standard '&/) +(define-special-primitive/standard '&=) +(define-special-primitive/standard '&<) +(define-special-primitive/standard '&>) +(define-special-primitive/standard '1+) +(define-special-primitive/standard '-1+) +(define-special-primitive/standard 'zero?) +(define-special-primitive/standard 'positive?) +(define-special-primitive/standard 'negative?) + + diff --git a/v7/src/compiler/machines/spectrum/rules1.scm b/v7/src/compiler/machines/spectrum/rules1.scm new file mode 100644 index 000000000..12ac64ec2 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/rules1.scm @@ -0,0 +1,268 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules1.scm,v 4.32 1990/01/25 16:39:51 jinx Exp $ +$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $ + +Copyright (c) 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Data Transfers + +(declare (usual-integrations)) + +;;;; Simple Operations + +;;; All assignments to pseudo registers are required to delete the +;;; dead registers BEFORE performing the assignment. However, it is +;;; necessary to derive the effective address of the source +;;; expression(s) before deleting the dead registers. Otherwise any +;;; source expression containing dead registers might refer to aliases +;;; which have been reused. + +(define-rule statement + (ASSIGN (REGISTER (? target)) (REGISTER (? source))) + (standard-move-to-target! source target) + (LAP)) + +(define-rule statement + ;; tag the contents of a register + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum)))) + (let* ((type (standard-source! type)) + (target (standard-move-to-target! datum target))) + (LAP (DEP () ,type ,(-1+ scheme-type-width) ,scheme-type-width ,target)))) + +(define-rule statement + ;; tag the contents of a register + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source)))) + (QUALIFIER (fits-in-5-bits-signed? type)) + (deposit-type type (standard-move-to-target! source target))) + +(define-rule statement + ;; extract the type part of a register's contents + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) + (standard-unary-conversion source target object->type)) + +(define-rule statement + ;; extract the datum part of a register's contents + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) + (standard-unary-conversion source target object->datum)) + +(define-rule statement + ;; convert the contents of a register to an address + (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) + (object->address (standard-move-to-target! source target))) + +(define-rule statement + ;; add a constant to a register's contents + (ASSIGN (REGISTER (? target)) + (OFFSET-ADDRESS (REGISTER (? source)) (? offset))) + (standard-unary-conversion source target + (lambda (source target) + (load-offset (* 4 offset) source target)))) + +(define-rule statement + ;; read an object from memory + (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) + (standard-unary-conversion address target + (lambda (address target) + (load-word (* 4 offset) address target)))) + +(define-rule statement + ;; pop an object off the stack + (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 22) 1)) + (LAP (LDWM () (OFFSET 4 0 22) ,(standard-target! target)))) + +;;;; Loading of Constants + +(define-rule statement + ;; load a machine constant + (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source))) + (load-immediate source (standard-target! target))) + +(define-rule statement + ;; load a Scheme constant + (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) + (load-constant source (standard-target! target))) + +(define-rule statement + ;; load the type part of a Scheme constant + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant)))) + (load-non-pointer 0 (object-type constant) (standard-target! target))) + +(define-rule statement + ;; load the datum part of a Scheme constant + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) + (QUALIFIER (non-pointer-object? constant)) + (load-non-pointer 0 + (careful-object-datum constant) + (standard-target! target))) + +(define-rule statement + ;; load a synthesized constant + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (load-non-pointer type datum (standard-target! target))) + +(define-rule statement + ;; load the address of a variable reference cache + (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) + (load-pc-relative (free-reference-label name) + (standard-target! target))) + +(define-rule statement + ;; load the address of an assignment cache + (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) + (load-pc-relative (free-assignment-label name) + (standard-target! target))) + +(define-rule statement + ;; load the address of a procedure's entry point + (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) + (load-pc-relative-address label (standard-target! target))) + +(define-rule statement + ;; load the address of a continuation + (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) + (load-pc-relative-address label (standard-target! target))) + +;;; Spectrum optimizations + +(define (load-entry label target) + (let ((target (standard-target! target))) + (LAP ,@(load-pc-relative-address label target) + ,@(address->entry target)))) + +(define-rule statement + ;; load a procedure object + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (QUALIFIER (= type (ucode-type compiled-entry))) + (load-entry label target)) + +(define-rule statement + ;; load a return address object + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:CONTINUATION (? label)))) + (QUALIFIER (= type (ucode-type compiled-entry))) + (load-entry label target)) + +;;;; Transfers to Memory + +(define-rule statement + ;; store an object in memory + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) + (? source register-expression)) + (QUALIFIER (word-register? source)) + (store-word (standard-source! source) + (* 4 offset) + (standard-source! address))) + +(define-rule statement + ;; Push an object register on the heap + (ASSIGN (POST-INCREMENT (REGISTER 21) 1) (? source register-expression)) + (QUALIFIER (word-register? source)) + (LAP (STWM () ,(standard-source! source) (OFFSET 4 0 21)))) + +(define-rule statement + ;; Push an object register on the stack + (ASSIGN (PRE-INCREMENT (REGISTER 22) -1) (? source register-expression)) + (QUALIFIER (word-register? source)) + (LAP (STWM () ,(standard-source! source) (OFFSET -4 0 22)))) + +;; Cheaper, common patterns. + +(define-rule statement + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) (MACHINE-CONSTANT 0)) + (store-word 0 + (* 4 offset) + (standard-source! address))) + +(define-rule statement + (ASSIGN (POST-INCREMENT (REGISTER 21) 1) (MACHINE-CONSTANT 0)) + (LAP (STWM () 0 (OFFSET 4 0 21)))) + +(define-rule statement + (ASSIGN (PRE-INCREMENT (REGISTER 22) -1) (MACHINE-CONSTANT 0)) + (LAP (STWM () 0 (OFFSET -4 0 22)))) + +;;;; CHAR->ASCII/BYTE-OFFSET + +(define-rule statement + ;; load char object from memory and convert to ASCII byte + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset)))) + (standard-unary-conversion address target + (lambda (address target) + (load-byte (+ 3 (* 4 offset)) address target)))) + +(define-rule statement + ;; load ASCII byte from memory + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET (REGISTER (? address)) (? offset))) + (standard-unary-conversion address target + (lambda (address target) + (load-byte offset address target)))) + +(define-rule statement + ;; convert char object to ASCII byte + ;; Missing optimization: If source is home and this is the last + ;; reference (it is dead afterwards), an LDB could be done instead + ;; of an LDW followed by an object->datum. This is unlikely since + ;; the value will be home only if we've spilled it, which happens + ;; rarely. + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (REGISTER (? source)))) + (standard-unary-conversion source target + (lambda (source target) + (LAP (EXTRU () ,source 31 8 ,target))))) + +(define-rule statement + ;; store null byte in memory + (ASSIGN (BYTE-OFFSET (REGISTER (? source)) (? offset)) + (CHAR->ASCII (CONSTANT #\NUL))) + (store-byte 0 offset (standard-source! source))) + +(define-rule statement + ;; store ASCII byte in memory + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (REGISTER (? source))) + (store-byte (standard-source! source) offset (standard-source! address))) + +(define-rule statement + ;; convert char object to ASCII byte and store it in memory + ;; register + byte offset <- contents of register (clear top bits) + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (CHAR->ASCII (REGISTER (? source)))) + (store-byte (standard-source! source) offset (standard-source! address))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/rules2.scm b/v7/src/compiler/machines/spectrum/rules2.scm new file mode 100644 index 000000000..c67240d22 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/rules2.scm @@ -0,0 +1,85 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules2.scm,v 4.12 1990/01/25 16:40:55 jinx Rel $ +$MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $ + +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Predicates + +(declare (usual-integrations)) + +(define-rule predicate + ;; test for two registers EQ? + (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2))) + (compare '= (standard-source! source1) (standard-source! source2))) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register))) + (eq-test/constant*register constant register)) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant))) + (eq-test/constant*register constant register)) + +(define (eq-test/constant*register constant source) + (let ((source (standard-source! source))) + (if (non-pointer-object? constant) + (compare-immediate '= (non-pointer->literal constant) source) + (let ((temp (standard-temporary!))) + (LAP ,@(load-constant constant temp) + ,@(compare '= temp source)))))) + +(define-rule predicate + ;; test for register EQ? to synthesized constant + (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum))) + (REGISTER (? register))) + (eq-test/synthesized-constant*register type datum register)) + +(define-rule predicate + ;; test for register EQ? to synthesized constant + (EQ-TEST (REGISTER (? register)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (eq-test/synthesized-constant*register type datum register)) + +(define (eq-test/synthesized-constant*register type datum source) + (compare-immediate '= + (make-non-pointer-literal type datum) + (standard-source! source))) + +(define-rule predicate + ;; Branch if virtual register contains the specified type number + (TYPE-TEST (REGISTER (? register)) (? type)) + (compare-immediate '= type (standard-source! register))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/rules3.scm b/v7/src/compiler/machines/spectrum/rules3.scm new file mode 100644 index 000000000..da0ad69c8 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/rules3.scm @@ -0,0 +1,588 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules3.scm,v 4.23 1990/01/25 16:42:42 jinx Exp $ +$MC68020-Header: rules3.scm,v 4.23 90/01/18 22:44:09 GMT cph Exp $ + +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Invocations and Entries + +(declare (usual-integrations)) + +;;;; Invocations + +(define-rule statement + (POP-RETURN) + (pop-return)) + +(define (pop-return) + (let ((temp (standard-temporary!))) + (LAP ,@(clear-map!) + ;; This assumes that the return address is always longword aligned + ;; (it better be, since instructions should be longword aligned). + ;; Thus the bottom two bits of temp are 0, representing the + ;; highest privilege level, and the privilege level will + ;; not be changed by the BV instruction. + (LDWM () (OFFSET 4 0 22) ,temp) + ,@(object->address temp) + (BV (N) 0 ,temp)))) + +(define-rule statement + (INVOCATION:APPLY (? frame-size) (? continuation)) + continuation ;ignore + (LAP ,@(clear-map!) + ,@(load-immediate frame-size regnum:second-arg) + (LDWM () (OFFSET 4 0 22) ,regnum:first-arg) ; procedure + ,@(invoke-interface code:compiler-apply))) + +(define-rule statement + (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) + frame-size continuation ;ignore + (LAP ,@(clear-map!) + (B (N) (@PCR ,label)))) + +(define-rule statement + (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation)) + frame-size continuation ;ignore + ;; It expects the procedure at the top of the stack + (pop-return)) + +(define-rule statement + (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) + continuation ;ignore + (LAP ,@(clear-map!) + ,@(load-immediate number-pushed regnum:second-arg) + ,@(load-pc-relative-address label regnum:first-arg) + ,@(invoke-interface code:compiler-lexpr-apply))) + +(define-rule statement + (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation)) + continuation ;ignore + ;; Destination address is at TOS; pop it into first-arg + (LAP ,@(clear-map!) + (LDWM () (OFFSET 4 0 22) ,regnum:first-arg) + ,@(load-immediate number-pushed regnum:second-arg) + ,@(object->address regnum:first-arg) + ,@(invoke-interface code:compiler-lexpr-apply))) + +(define-rule statement + (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) + continuation ;ignore + (LAP ,@(clear-map!) + (B (N) (@PCR ,(free-uuo-link-label name frame-size))))) + +(define-rule statement + (INVOCATION:CACHE-REFERENCE (? frame-size) + (? continuation) + (? extension register-expression)) + continuation ;ignore + (LAP ,@(load-interface-args! extension false false false) + ,@(load-immediate frame-size regnum:third-arg) + ,@(load-pc-relative-address *block-label* regnum:second-arg) + ,@(invoke-interface code:compiler-cache-reference-apply))) + +(define-rule statement + (INVOCATION:LOOKUP (? frame-size) + (? continuation) + (? environment register-expression) + (? name)) + continuation ;ignore + (LAP ,@(load-interface-args! environment false false false) + ,(load-constant name regnum:second-arg) + ,(load-immediate frame-size regnum:third-arg) + ,@(invoke-interface code:compiler-lookup-apply))) + +(define-rule statement + (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) + continuation ;ignore + (if (eq? primitive compiled-error-procedure) + (LAP ,@(clear-map!) + ,@(load-immediate frame-size regnum:first-arg) + ,@(invoke-interface code:compiler-error)) + (LAP ,@(clear-map!) + ,@(load-pc-relative (constant->label primitive) + regnum:first-arg) + ,@(let ((arity (primitive-procedure-arity primitive))) + (cond ((not (negative? arity)) + (invoke-interface code:compiler-primitive-apply)) + ((= arity -1) + (LAP ,@(load-immediate (-1+ frame-size) 1) + (STW () 1 ,reg:lexpr-primitive-arity) + ,@(invoke-interface + code:compiler-primitive-lexpr-apply))) + (else + ;; Unknown primitive arity. Go through apply. + (LAP ,@(load-immediate frame-size regnum:second-arg) + ,@(invoke-interface code:compiler-apply)))))))) + +(let-syntax + ((define-special-primitive-invocation + (macro (name) + `(define-rule statement + (INVOCATION:SPECIAL-PRIMITIVE + (? frame-size) + (? continuation) + ,(make-primitive-procedure name true)) + frame-size continuation + ,(list 'LAP + (list 'UNQUOTE-SPLICING '(clear-map!)) + (list 'UNQUOTE-SPLICING + `(INVOKE-INTERFACE ,(symbol-append 'CODE:COMPILER- + name)))))))) + (define-special-primitive-invocation &+) + (define-special-primitive-invocation &-) + (define-special-primitive-invocation &*) + (define-special-primitive-invocation &/) + (define-special-primitive-invocation &=) + (define-special-primitive-invocation &<) + (define-special-primitive-invocation &>) + (define-special-primitive-invocation 1+) + (define-special-primitive-invocation -1+) + (define-special-primitive-invocation zero?) + (define-special-primitive-invocation positive?) + (define-special-primitive-invocation negative?)) + +;;;; Invocation Prefixes + +;;; MOVE-FRAME-UP size address +;;; +;;; Moves up the last words of the stack so that the first of +;;; these words is at location
, and resets the stack pointer +;;; to the last of these words. That is, it pops off all the words +;;; between
and TOS+/-. + +(define-rule statement + ;; Move up 0 words back to top of stack : a No-Op + (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 22)) + (LAP)) + +(define-rule statement + ;; Move words back to dynamic link marker + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 19)) + (generate/move-frame-up frame-size + (lambda (reg) (LAP (COPY () 19 ,reg))))) + +(define-rule statement + ;; Move words back to SP+offset + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) + (OFFSET-ADDRESS (REGISTER 22) (? offset))) + (let ((how-far (* 4 (- offset frame-size)))) + (cond ((zero? how-far) + (LAP)) + ((negative? how-far) + (error "invocation-prefix:move-frame-up: bad specs" + frame-size offset)) + ((zero? frame-size) + (load-offset how-far 22 22)) + ((= frame-size 1) + (let ((temp (standard-temporary!))) + (LAP (LDWM () (OFFSET ,how-far 0 22) ,temp) + (STW () ,temp (OFFSET 0 0 22))))) + ((= frame-size 2) + (let ((temp1 (standard-temporary!)) + (temp2 (standard-temporary!))) + (LAP (LDWM () (OFFSET 4 0 22) ,temp1) + (LDWM () (OFFSET ,(- how-far 4) 0 22) ,temp2) + (STW () ,temp1 (OFFSET 0 0 22)) + (STW () ,temp2 (OFFSET 4 0 22))))) + (else + (generate/move-frame-up frame-size + (lambda (reg) + (load-offset (* 4 offset) 22 reg))))))) + +(define-rule statement + ;; Move words back to base virtual register + offset + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) + (OFFSET-ADDRESS (REGISTER (? base)) + (? offset))) + (generate/move-frame-up frame-size + (lambda (reg) + (load-offset (* 4 offset) (standard-source! base) reg)))) + +;;; DYNAMIC-LINK instructions have a , , +;;; and as arguments. They pop the stack by +;;; removing the lesser of the amount needed to move the stack pointer +;;; back to the or . The last +;;; words on the stack (the stack frame for the procedure +;;; about to be called) are then put back onto the newly adjusted +;;; stack. + +(define-rule statement + (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) + (REGISTER (? source)) + (REGISTER 19)) + (if (and (zero? frame-size) + (= source regnum:stack-pointer)) + (LAP) + (let ((env-reg (standard-move-to-temporary! source))) + (LAP (SUB (<<=) ,env-reg 19 0) ; skip if env LS dyn link + (COPY () 19 ,env-reg) ; env <- dyn link + ,@(generate/move-frame-up* frame-size env-reg))))) + +(define (generate/move-frame-up frame-size destination-generator) + (let ((temp (standard-temporary!))) + (LAP ,@(destination-generator temp) + ,@(generate/move-frame-up* frame-size temp)))) + +(define (generate/move-frame-up* frame-size destination) + ;; Destination is guaranteed to be a machine register number; that + ;; register has the destination base address for the frame. The stack + ;; pointer is reset to the top end of the copied area. + (LAP ,@(case frame-size + ((0) + (LAP)) + ((1) + (let ((temp (standard-temporary!))) + (LAP (LDW () (OFFSET 0 0 22) ,temp) + (STWM () ,temp (OFFSET -4 0 ,destination))))) + (else + (generate/move-frame-up** frame-size destination))) + (COPY () ,destination 22))) + +(define (generate/move-frame-up** frame-size dest) + (let ((from (standard-temporary!)) + (temp1 (standard-temporary!)) + (temp2 (standard-temporary!))) + (LAP ,@(load-offset (* 4 frame-size) regnum:stack-pointer from) + ,@(if (<= frame-size 3) + ;; This code can handle any number > 1 (handled above), + ;; but we restrict it to 3 for space reasons. + (let loop ((n frame-size)) + (case n + ((0) + (LAP)) + ((3) + (let ((temp3 (standard-temporary!))) + (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1) + (LDWM () (OFFSET -4 0 ,from) ,temp2) + (LDWM () (OFFSET -4 0 ,from) ,temp3) + (STWM () ,temp1 (OFFSET -4 0 ,dest)) + (STWM () ,temp2 (OFFSET -4 0 ,dest)) + (STWM () ,temp3 (OFFSET -4 0 ,dest))))) + (else + (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1) + (LDWM () (OFFSET -4 0 ,from) ,temp2) + (STWM () ,temp1 (OFFSET -4 0 ,dest)) + (STWM () ,temp2 (OFFSET -4 0 ,dest)) + ,@(loop (- n 2)))))) + (LAP ,@(load-immediate frame-size temp2) + (LDWM () (OFFSET -4 0 ,from) ,temp1) + (ADDIBF (=) -1 ,temp2 (@PCO -12)) + (STWM () ,temp1 (OFFSET -4 0 ,dest))))))) + +;;;; External Labels + +(define (make-external-label code label) + (set! *external-labels* (cons label *external-labels*)) + (LAP (EXTERNAL-LABEL () ,code (@PCR ,label)) + (LABEL ,label))) + +;;; Entry point types + +(define-integrable (make-code-word min max) + (+ (* #x100 min) max)) + +(define (make-procedure-code-word min max) + ;; The "min" byte must be less than #x80; the "max" byte may not + ;; equal #x80 but can take on any other value. + (if (or (negative? min) (>= min #x80)) + (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min)) + (if (>= (abs max) #x80) + (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max)) + (make-code-word min (if (negative? max) (+ #x100 max) max))) + +(define expression-code-word + (make-code-word #xff #xff)) + +(define internal-entry-code-word + (make-code-word #xff #xfe)) + +(define (continuation-code-word label) + (let ((offset + (if label + (rtl-continuation/next-continuation-offset (label->object label)) + 0))) + (cond ((not offset) + (make-code-word #xff #xfc)) + ((< offset #x2000) + ;; This uses up through (#xff #xdf). + (let ((qr (integer-divide offset #x80))) + (make-code-word (+ #x80 (integer-divide-remainder qr)) + (+ #x80 (integer-divide-quotient qr))))) + (else + (error "Unable to encode continuation offset" offset))))) + +;;;; Procedure headers + +;;; The following calls MUST appear as the first thing at the entry +;;; point of a procedure. They assume that the register map is clear +;;; and that no register contains anything of value. + +;;; **** The only reason that this is true is that no register is live +;;; across calls. If that were not true, then we would have to save +;;; any such registers on the stack so that they would be GC'ed +;;; appropriately. +;;; +;;; **** This is not strictly true: the dynamic link register may +;;; contain a valid dynamic link, but the gc handler determines that +;;; and saves it as appropriate. + +(define (simple-procedure-header code-word label code) + (let ((gc-label (generate-label))) + (LAP (LABEL ,gc-label) + ,@(invoke-interface-ble code) + ,@(make-external-label code-word label) + ,@(interrupt-check gc-label)))) + +(define (dlink-procedure-header code-word label) + (let ((gc-label (generate-label))) + (LAP (LABEL ,gc-label) + (COPY () ,regnum:dynamic-link ,regnum:second-arg) + ,@(invoke-interface-ble code:compiler-interrupt-dlink) + ,@(make-external-label code-word label) + ,@(interrupt-check gc-label)))) + +(define (interrupt-check gc-label) + (LAP (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer (@PCR ,gc-label)) + (LDW () ,reg:memtop ,regnum:memtop-pointer))) + +(define-rule statement + (CONTINUATION-ENTRY (? internal-label)) + (make-external-label (continuation-code-word internal-label) + internal-label)) + +(define-rule statement + (CONTINUATION-HEADER (? internal-label)) + (simple-procedure-header (continuation-code-word internal-label) + internal-label + code:compiler-interrupt-continuation)) + +(define-rule statement + (IC-PROCEDURE-HEADER (? internal-label)) + (let ((procedure (label->object internal-label))) + (let ((external-label (rtl-procedure/external-label procedure))) + (LAP (ENTRY-POINT ,external-label) + (EQUATE ,external-label ,internal-label) + ,@(simple-procedure-header expression-code-word + internal-label + code:compiler-interrupt-ic-procedure))))) + +(define-rule statement + (OPEN-PROCEDURE-HEADER (? internal-label)) + (let ((rtl-proc (label->object internal-label))) + (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label) + ,@((if (rtl-procedure/dynamic-link? rtl-proc) + dlink-procedure-header + (lambda (code-word label) + (simple-procedure-header code-word label + code:compiler-interrupt-procedure))) + internal-entry-code-word + internal-label)))) + +(define-rule statement + (PROCEDURE-HEADER (? internal-label) (? min) (? max)) + (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label)) + ,internal-label) + ,@(simple-procedure-header (make-procedure-code-word min max) + internal-label + code:compiler-interrupt-procedure))) + +;;;; Closures. These two statements are intertwined: + +;; Magic for compiled entries. + +(define compiled-entry-type-im5 + (let* ((qr (integer-divide (ucode-type compiled-entry) 2)) + (immed (integer-divide-quotient qr))) + (if (or (not (= scheme-type-width 6)) + (not (zero? (integer-divide-remainder qr))) + (not (<= 0 immed #x1F))) + (error "closure header rule assumptions violated!")) + (if (<= immed #x0F) + immed + (- immed #x20)))) + +(define-integrable (address->entry register) + (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register))) + +(define-rule statement + ;; This depends on the following facts: + ;; 1- tc_compiled_entry is a multiple of two. + ;; 2- all the top 6 bits in a data address are 0 except the quad bit + ;; 3- type codes are 6 bits long. + (CLOSURE-HEADER (? internal-label)) + (let ((procedure (label->object internal-label))) + (let ((gc-label (generate-label)) + (external-label (rtl-procedure/external-label procedure))) + (LAP (LABEL ,gc-label) + ,@(invoke-interface code:compiler-interrupt-closure) + ,@(make-external-label internal-entry-code-word external-label) + (DEP () 0 31 2 ,regnum:ble-return) + ,@(address->entry regnum:ble-return) + (STWM () ,regnum:ble-return (OFFSET -4 0 22)) + (LABEL ,internal-label) + ,@(interrupt-check gc-label))))) + +(define (cons-closure target label min max size ->entry?) + (let ((flush-reg (clear-registers! regnum:ble-return))) + (need-register! regnum:ble-return) + (let ((dest (standard-target! target))) + ;; Note: dest is used as a temporary before the BLE instruction, + ;; and is written immediately afterwards. + (LAP ,@flush-reg + ,@(load-non-pointer (ucode-type manifest-closure) (+ 4 size) dest) + (STWM () ,dest (OFFSET 4 0 21)) + ,@(load-immediate + (+ (* (make-procedure-code-word min max) #x10000) 4) + dest) + (STWM () ,dest (OFFSET 4 0 21)) + ,@(load-pc-relative-address + (rtl-procedure/external-label (label->object label)) + 1) + (BLE () + (OFFSET ,hook:compiler-store-closure-code + 4 + ,regnum:scheme-to-interface-ble)) + (COPY () ,regnum:free-pointer ,dest) + ,@(if ->entry? + (address->entry dest) + (LAP)) + ,@(load-offset (* 4 size) + regnum:free-pointer + regnum:free-pointer))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? size)))) + (QUALIFIER (= type (ucode-type compiled-entry))) + (cons-closure target procedure-label min max size true)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? size))) + (QUALIFIER (= type (ucode-type compiled-entry))) + (cons-closure target procedure-label min max size false)) + +;;;; Entry Header +;;; This is invoked by the top level of the LAP generator. + +(define (generate/quotation-header environment-label free-ref-label n-sections) + ;; Calls the linker + (LAP (LDW () ,reg:environment 2) + ,@(load-pc-relative-address environment-label 1) + (STW () 2 (OFFSET 0 0 1)) + ,@(load-pc-relative-address *block-label* regnum:second-arg) + ,@(load-pc-relative-address free-ref-label regnum:third-arg) + ,@(load-immediate n-sections regnum:fourth-arg) + ,@(invoke-interface-ble code:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label)))) + +(define (generate/remote-link code-block-label + environment-offset + free-ref-offset + n-sections) + ;; Link all of the top level procedures within the file + (LAP ,@(load-pc-relative code-block-label regnum:second-arg) + ,@(object->address regnum:second-arg) + (LDW () ,reg:environment 2) + ,@(load-offset environment-offset regnum:second-arg 1) + (STW () 2 (OFFSET 0 0 1)) + ,@(load-offset free-ref-offset regnum:second-arg regnum:third-arg) + ,@(load-immediate n-sections regnum:fourth-arg) + ,@(invoke-interface-ble code:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label)))) + +(define (generate/constants-block constants references assignments uuo-links) + (let ((constant-info + (declare-constants 0 (transmogrifly uuo-links) + (declare-constants 1 references + (declare-constants 2 assignments + (declare-constants false constants + (cons false (LAP)))))))) + (let ((free-ref-label (car constant-info)) + (constants-code (cdr constant-info)) + (debugging-information-label (allocate-constant-label)) + (environment-label (allocate-constant-label)) + (n-sections + (+ (if (null? uuo-links) 0 1) + (if (null? references) 0 1) + (if (null? assignments) 0 1)))) + (values + (LAP ,@constants-code + ;; Place holder for the debugging info filename + (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO) + ;; Place holder for the load time environment if needed + (SCHEME-OBJECT ,environment-label + ,(if (null? free-ref-label) 0 'ENVIRONMENT))) + environment-label + free-ref-label + n-sections)))) + +(define (declare-constants tag constants info) + (define (inner constants) + (if (null? constants) + (cdr info) + (let ((entry (car constants))) + (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry)) + ,@(inner (cdr constants)))))) + (if (and tag (not (null? constants))) + (let ((label (allocate-constant-label))) + (cons label + (inner + `((,(let ((datum (length constants))) + (if (> datum #xffff) + (error "datum too large" datum)) + (+ (* tag #x10000) datum)) + . ,label) + ,@constants)))) + (cons (car info) (inner constants)))) + +(define (transmogrifly uuos) + (define (inner name assoc) + (if (null? assoc) + (transmogrifly (cdr uuos)) + `((,name . ,(cdar assoc)) ; uuo-label LDIL + (0 . ,(allocate-constant-label)) ; spare BLE + (,(caar assoc) . ; frame-size + ,(allocate-constant-label)) + ,@(inner name (cdr assoc))))) + (if (null? uuos) + '() + (inner (caar uuos) (cdar uuos)))) + +;;; Local Variables: *** +;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** +;;; End: *** diff --git a/v7/src/compiler/machines/spectrum/rules4.scm b/v7/src/compiler/machines/spectrum/rules4.scm new file mode 100644 index 000000000..db92bfa88 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/rules4.scm @@ -0,0 +1,101 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules4.scm,v 4.11 1990/01/25 16:43:39 jinx Rel $ +$MC68020-Header: rules4.scm,v 4.11 90/01/20 07:26:13 GMT cph Exp $ + +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Interpreter Calls + +(declare (usual-integrations)) + +;;;; Interpreter Calls + +(define-rule statement + (INTERPRETER-CALL:ACCESS (? environment register-expression) (? name)) + (lookup-call code:compiler-access environment name)) + +(define-rule statement + (INTERPRETER-CALL:LOOKUP (? environment register-expression) + (? name) + (? safe?)) + (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup) + environment + name)) + +(define-rule statement + (INTERPRETER-CALL:UNASSIGNED? (? environment register-expression) (? name)) + (lookup-call code:compiler-unassigned? environment name)) + +(define-rule statement + (INTERPRETER-CALL:UNBOUND? (? environment register-expression) (? name)) + (lookup-call code:compiler-unbound? environment name)) + +(define (lookup-call code environment name) + (LAP ,@(load-interface-args! false environment false false) + ,@(load-constant name regnum:third-arg) + ,@(invoke-interface-ble code))) + +(define-rule statement + (INTERPRETER-CALL:DEFINE (? environment register-expression) + (? name) + (? value register-expression)) + (assignment-call code:compiler-define environment name value)) + +(define-rule statement + (INTERPRETER-CALL:SET! (? environment register-expression) + (? name) + (? value register-expression)) + (assignment-call code:compiler-set! environment name value)) + +(define (assignment-call code environment name value) + (LAP ,@(load-interface-args! false environment false value) + ,@(load-constant name regnum:third-arg) + ,@(invoke-interface-ble code))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-REFERENCE (REGISTER (? extension)) (? safe?)) + (LAP ,@(load-interface-args! false extension false false) + ,@(invoke-interface-ble + (if safe? + code:compiler-safe-reference-trap + code:compiler-reference-trap)))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-ASSIGNMENT (REGISTER (? extension)) + (? value register-expression)) + (LAP ,@(load-interface-args! false extension value false) + ,@(invoke-interface-ble code:compiler-assignment-trap))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-UNASSIGNED? (REGISTER (? extension))) + (LAP ,@(load-interface-args! false extension false false) + ,@(invoke-interface-ble code:compiler-unassigned?-trap))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/rulfix.scm b/v7/src/compiler/machines/spectrum/rulfix.scm new file mode 100644 index 000000000..5efc3fd20 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/rulfix.scm @@ -0,0 +1,356 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rulfix.scm,v 4.32 1990/01/25 16:44:44 jinx Exp $ +$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $ + +Copyright (c) 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Fixnum Rules + +(declare (usual-integrations)) + +;;;; Conversions + +(define-rule statement + ;; convert a fixnum object to a "fixnum integer" + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source)))) + (standard-unary-conversion source target object->fixnum)) + +(define-rule statement + ;; load a fixnum constant as a "fixnum integer" + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant)))) + (load-fixnum-constant constant (standard-target! target))) + +(define-rule statement + ;; convert a memory address to a "fixnum integer" + (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source)))) + (standard-unary-conversion source target address->fixnum)) + +(define-rule statement + ;; convert an object's address to a "fixnum integer" + (ASSIGN (REGISTER (? target)) + (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source))))) + (standard-unary-conversion source target object->fixnum)) + +(define-rule statement + ;; convert a "fixnum integer" to a fixnum object + (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source)))) + (standard-unary-conversion source target fixnum->object)) + +(define-rule statement + ;; convert a "fixnum integer" to a memory address + (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source)))) + (standard-unary-conversion source target fixnum->address)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (OBJECT->FIXNUM (CONSTANT 4)) + (OBJECT->FIXNUM (REGISTER (? source))) + #F)) + (standard-unary-conversion source target object->index-fixnum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (OBJECT->FIXNUM (REGISTER (? source))) + (OBJECT->FIXNUM (CONSTANT 4)) + #F)) + (standard-unary-conversion source target object->index-fixnum)) + +;; This is a patch for the time being. Probably only one of these pairs +;; of rules is needed. + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (OBJECT->FIXNUM (CONSTANT 4)) + (REGISTER (? source)) + #F)) + (standard-unary-conversion source target fixnum->index-fixnum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (REGISTER (? source)) + (OBJECT->FIXNUM (CONSTANT 4)) + #F)) + (standard-unary-conversion source target fixnum->index-fixnum)) + +(define-integrable (fixnum->index-fixnum src tgt) + (LAP (SHD () ,src 0 30 ,tgt))) + +(define-integrable (object->fixnum src tgt) + (LAP (SHD () ,src 0 ,scheme-datum-width ,tgt))) + +(define-integrable (object->index-fixnum src tgt) + (LAP (SHD () ,src 0 ,(- scheme-datum-width 2) ,tgt))) + +(define-integrable (address->fixnum src tgt) + (LAP (SHD () ,src 0 ,scheme-datum-width ,tgt))) + +(define-integrable (fixnum->object src tgt) + (LAP ,@(load-immediate (ucode-type fixnum) regnum:addil-result) + (SHD () ,regnum:addil-result ,src ,scheme-type-width ,tgt))) + +(define (fixnum->address src tgt) + (LAP (SHD () ,regnum:quad-bitmask ,src ,scheme-type-width ,tgt))) + +(define (load-fixnum-constant constant target) + (load-immediate (* constant fixnum-1) target)) + +(define-integrable fixnum-1 + (expt 2 scheme-type-width)) + +;;;; Arithmetic Operations + +(define-rule statement + ;; execute a unary fixnum operation + (ASSIGN (REGISTER (? target)) + (FIXNUM-1-ARG (? operation) + (REGISTER (? source)) + (? overflow?))) + (standard-unary-conversion source target + (lambda (source target) + ((fixnum-1-arg/operator operation) target source overflow?)))) + +(define (fixnum-1-arg/operator operation) + (lookup-arithmetic-method operation fixnum-methods/1-arg)) + +(define fixnum-methods/1-arg + (list 'FIXNUM-METHODS/1-ARG)) + +(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg + (lambda (tgt src overflow?) + (if overflow? + (LAP (ADDI (NSV) ,fixnum-1 ,src ,tgt)) + (LAP (ADDI () ,fixnum-1 ,src ,tgt))))) + +(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg + (lambda (tgt src overflow?) + (if overflow? + (LAP (ADDI (NSV) ,(- fixnum-1) ,src ,tgt)) + (LAP (ADDI () ,(- fixnum-1) ,src ,tgt))))) + +(define-rule statement + ;; execute a binary fixnum operation + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + (standard-binary-conversion source1 source2 target + (lambda (source1 source2 target) + ((fixnum-2-args/operator operation) target source1 source2 overflow?)))) + +(define (fixnum-2-args/operator operation) + (lookup-arithmetic-method operation fixnum-methods/2-args)) + +(define fixnum-methods/2-args + (list 'FIXNUM-METHODS/2-ARGS)) + +(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (if overflow? + (LAP (ADD (NSV) ,src1 ,src2 ,tgt)) + (LAP (ADD () ,src1 ,src2 ,tgt))))) + +(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (if overflow? + (LAP (SUB (NSV) ,src1 ,src2 ,tgt)) + (LAP (SUB () ,src1 ,src2 ,tgt))))) + +(define-rule statement + ;; execute binary fixnum operation with constant second arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source)) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (? overflow?))) + (standard-unary-conversion source target + (lambda (source target) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?)))) + +(define-rule statement + ;; execute binary fixnum operation with constant first arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (REGISTER (? source)) + (? overflow?))) + (standard-unary-conversion source target + (lambda (source target) + (if (fixnum-2-args/commutative? operation) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?) + ((fixnum-2-args/operator/constant*register operation) + target constant source overflow?))))) + +(define (fixnum-2-args/commutative? operator) + (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM))) + +(define (fixnum-2-args/operator/register*constant operation) + (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant)) + +(define fixnum-methods/2-args/register*constant + (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT)) + +(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (let ((value (* constant fixnum-1))) + (if overflow? + (cond ((zero? constant) + (LAP (SKIP (TR)))) + ((fits-in-11-bits-signed? value) + (LAP (ADDI (NSV) ,value ,src ,tgt))) + (else + (let ((temp (standard-temporary!))) + (LAP ,@(load-fixnum-constant constant temp) + (ADD (NSV) ,src ,temp ,tgt))))) + (load-offset value src tgt))))) + +(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (let ((value (- (* constant fixnum-1)))) + (if overflow? + (cond ((zero? constant) + (LAP (SKIP (TR)))) + ((fits-in-11-bits-signed? value) + (LAP (ADDI (NSV) ,value ,src ,tgt))) + (else + (let ((temp (standard-temporary!))) + (LAP ,@(load-fixnum-constant constant temp) + (SUB (NSV) ,src ,temp ,tgt))))) + (load-offset value src tgt))))) + +(define (fixnum-2-args/operator/constant*register operation) + (lookup-arithmetic-method operation fixnum-methods/2-args/constant*register)) + +(define fixnum-methods/2-args/constant*register + (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER)) + +(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/constant*register + (lambda (tgt constant src overflow?) + (guarantee-signed-fixnum constant) + (let ((value (* constant fixnum-1))) + (if (fits-in-11-bits-signed? value) + (if overflow? + (LAP (SUBI (NSV) ,value ,src ,tgt)) + (LAP (SUBI () ,value ,src ,tgt))) + (let ((temp (standard-temporary!))) + (LAP ,@(load-fixnum-constant constant temp) + ,@(if overflow? + (LAP (SUB (NSV) ,temp ,src ,tgt)) + (LAP (SUB () ,temp ,src ,tgt))))))))) + +(define (guarantee-signed-fixnum n) + (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n)) + n) + +(define (signed-fixnum? n) + (and (exact-integer? n) + (>= n signed-fixnum/lower-limit) + (< n signed-fixnum/upper-limit))) + +;;;; Predicates + +;;; This is a kludge. It assumes that the last instruction of the +;;; arithmetic operation that may cause an overflow condition will +;;; skip the following instruction if there was no overflow. Ie., the +;;; last instruction will conditionally nullify using NSV. The code +;;; for the alternative is a real kludge because we can't force the +;;; arithmetic instruction that precedes this code to use the inverted +;;; condition. Hopefully the peephole optimizer will fix this if it +;;; is ever generated. The linearizer attempts not to use this +;;; branch. + +(define-rule predicate + (OVERFLOW-TEST) + (set-current-branches! + (lambda (label) + (LAP (B (N) (@PCR ,label)))) + (lambda (label) + (LAP (SKIP (TR)) + (B (N) (@PCR ,label))))) + (LAP)) + +(define-rule predicate + (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source))) + (compare (fixnum-pred-1->cc predicate) + (standard-source! source) + 0)) + +(define (fixnum-pred-1->cc predicate) + (case predicate + ((ZERO-FIXNUM?) '=) + ((NEGATIVE-FIXNUM?) '<) + ((POSITIVE-FIXNUM?) '>) + (else (error "unknown fixnum predicate" predicate)))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (compare (fixnum-pred-2->cc predicate) + (standard-source! source1) + (standard-source! source2))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (REGISTER (? source)) + (OBJECT->FIXNUM (CONSTANT (? constant)))) + (compare-fixnum/constant*register (invert-condition-noncommutative + (fixnum-pred-2->cc predicate)) + constant + (standard-source! source))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (REGISTER (? source))) + (compare-fixnum/constant*register (fixnum-pred-2->cc predicate) + constant + (standard-source! source))) + +(define-integrable (compare-fixnum/constant*register cc n r) + (guarantee-signed-fixnum n) + (compare-immediate cc (* n fixnum-1) r)) + +(define (fixnum-pred-2->cc predicate) + (case predicate + ((EQUAL-FIXNUM?) '=) + ((LESS-THAN-FIXNUM?) '<) + ((GREATER-THAN-FIXNUM?) '>) + (else (error "unknown fixnum predicate" predicate)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/rulflo.scm b/v7/src/compiler/machines/spectrum/rulflo.scm new file mode 100644 index 000000000..90f09b053 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/rulflo.scm @@ -0,0 +1,187 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rulflo.scm,v 4.32 1990/01/25 16:45:49 jinx Rel $ +$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $ + +Copyright (c) 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Flonum rules + +(declare (usual-integrations)) + +(define (flonum-source! register) + (float-register->fpr (load-alias-register! register 'FLOAT))) + +(define (flonum-target! pseudo-register) + (delete-dead-registers!) + (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT))) + +(define (flonum-temporary!) + (float-register->fpr (allocate-temporary-register! 'FLOAT))) + +(define-rule statement + ;; convert a floating-point number to a flonum object + (ASSIGN (REGISTER (? target)) + (FLOAT->OBJECT (REGISTER (? source)))) + (let ((source (flonum-source! source)) + (temp (standard-temporary!))) + (let ((target (standard-target! target))) + (LAP ; (STW () 0 (OFFSET 0 0 21)) ; make heap parsable forwards + (DEPI () #b100 31 3 21) ; quad align + (COPY () 21 ,target) + ,@(deposit-type (ucode-type flonum) target) + ,@(load-non-pointer (ucode-type manifest-nm-vector) 2 temp) + (STWM () ,temp (OFFSET 4 0 21)) + (FSTDS (MA) ,source (OFFSET 8 0 21)))))) + +(define-rule statement + ;; convert a flonum object address to a floating-point number + (ASSIGN (REGISTER (? target)) (@ADDRESS->FLOAT (REGISTER (? source)))) + (let ((source (standard-source! source))) + (LAP (FLDDS () (OFFSET 4 0 ,source) ,(flonum-target! target))))) + +;;;; Flonum Arithmetic + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?))) + overflow? ;ignore + (let ((source (flonum-source! source))) + ((flonum-1-arg/operator operation) (flonum-target! target) source))) + +(define (flonum-1-arg/operator operation) + (lookup-arithmetic-method operation flonum-methods/1-arg)) + +(define flonum-methods/1-arg + (list 'FLONUM-METHODS/1-ARG)) + +;;; Notice the weird ,', syntax here. +;;; If LAP changes, this may also have to change. + +(let-syntax + ((define-flonum-operation + (macro (primitive-name opcode) + `(define-arithmetic-method ',primitive-name flonum-methods/1-arg + (lambda (target source) + (LAP (,opcode (DBL) ,',source ,',target))))))) + (define-flonum-operation flonum-abs FABS) + (define-flonum-operation flonum-sqrt FSQRT) + (define-flonum-operation flonum-round FRND)) + +(define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg + (lambda (target source) + #| + ;; No zero on the floating-point co-processor. Need to create one. + (let ((temp (if (= target source) (flonum-temporary!) target))) + (LAP (FSUB (DBL) ,temp ,temp ,temp) + (FSUB (DBL) ,temp ,source ,target))) + |# + ;; The status register (fr0) reads as 0 for non-store instructions. + (LAP (FSUB (DBL) 0 ,source ,target)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + overflow? ;ignore + (let ((source1 (flonum-source! source1)) + (source2 (flonum-source! source2))) + ((flonum-2-args/operator operation) (flonum-target! target) + source1 + source2))) + +(define (flonum-2-args/operator operation) + (lookup-arithmetic-method operation flonum-methods/2-args)) + +(define flonum-methods/2-args + (list 'FLONUM-METHODS/2-ARGS)) + +(let-syntax + ((define-flonum-operation + (macro (primitive-name opcode) + `(define-arithmetic-method ',primitive-name flonum-methods/2-args + (lambda (target source1 source2) + (LAP (,opcode (DBL) ,',source1 ,',source2 ,',target))))))) + (define-flonum-operation flonum-add fadd) + (define-flonum-operation flonum-subtract fsub) + (define-flonum-operation flonum-multiply fmpy) + (define-flonum-operation flonum-divide fdiv) + (define-flonum-operation flonum-remainder frem)) + +;;;; Flonum Predicates + +(define-rule predicate + (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source))) + #| + ;; No immediate zeros, easy to generate by subtracting from itself + (let ((temp (flonum-temporary!))) + (LAP (FSUB (DBL) ,temp ,temp ,temp) + ,@(flonum-compare + (case predicate + ((FLONUM-ZERO?) '=) + ((FLONUM-NEGATIVE?) '<) + ((FLONUM-POSITIVE?) '>) + (else (error "unknown flonum predicate" predicate))) + (flonum-source! source) + temp))) + |# + ;; The status register (fr0) reads as 0 for non-store instructions. + (flonum-compare (case predicate + ((FLONUM-ZERO?) '=) + ((FLONUM-NEGATIVE?) '<) + ((FLONUM-POSITIVE?) '>) + (else (error "unknown flonum predicate" predicate))) + (flonum-source! source) + 0)) + +(define-rule predicate + (FLONUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (flonum-compare (case predicate + ((FLONUM-EQUAL?) '=) + ((FLONUM-LESS?) '<) + ((FLONUM-GREATER?) '>) + (else (error "unknown flonum predicate" predicate))) + (flonum-source! source1) + (flonum-source! source2))) + +(define (flonum-compare cc r1 r2) + (set-current-branches! + (lambda (label) + (LAP (B (N) (@PCR ,label)))) + (lambda (label) + (LAP (SKIP (TR)) + (B (N) (@PCR ,label))))) + (LAP (FCMP (,(invert-condition cc) DBL) ,r1 ,r2) + (FTEST ()))) \ No newline at end of file -- 2.25.1