From 92039877b7a78c1c2a51c83e9ad3adebad6043fc Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 17 May 1989 20:31:24 +0000 Subject: [PATCH] New VAX port, May 1989. --- v7/src/compiler/machines/vax/assmd.scm | 83 ++- v7/src/compiler/machines/vax/coerce.scm | 27 +- v7/src/compiler/machines/vax/dassm1.scm | 284 ++++++--- v7/src/compiler/machines/vax/dassm2.scm | 198 +++--- v7/src/compiler/machines/vax/dassm3.scm | 201 +++--- v7/src/compiler/machines/vax/decls.scm | 771 +++++++++++++++--------- v7/src/compiler/machines/vax/dsyn.scm | 18 +- v7/src/compiler/machines/vax/inerly.scm | 69 ++- v7/src/compiler/machines/vax/insmac.scm | 19 +- v7/src/compiler/machines/vax/instr1.scm | 27 +- v7/src/compiler/machines/vax/instr2.scm | 5 +- v7/src/compiler/machines/vax/instr3.scm | 11 +- v7/src/compiler/machines/vax/insutl.scm | 59 +- v7/src/compiler/machines/vax/lapgen.scm | 495 ++++++++++----- v7/src/compiler/machines/vax/machin.scm | 157 +++-- v7/src/compiler/machines/vax/make.scm | 201 +----- v7/src/compiler/machines/vax/rgspcm.scm | 7 +- v7/src/compiler/machines/vax/rules1.scm | 349 +++++++---- v7/src/compiler/machines/vax/rules2.scm | 220 ++++--- v7/src/compiler/machines/vax/rules3.scm | 472 ++++++++++----- v7/src/compiler/machines/vax/rules4.scm | 117 ++-- 21 files changed, 2279 insertions(+), 1511 deletions(-) diff --git a/v7/src/compiler/machines/vax/assmd.scm b/v7/src/compiler/machines/vax/assmd.scm index e7adc0d38..bec42879d 100644 --- a/v7/src/compiler/machines/vax/assmd.scm +++ b/v7/src/compiler/machines/vax/assmd.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/assmd.scm,v 4.4 1988/02/23 18:18:47 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/assmd.scm,v 4.5 1989/05/17 20:27:46 jinx Rel $ +$MC68020-Header: assmd.scm,v 1.35 88/08/31 05:55:31 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,74 +34,62 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Assembler Machine Dependencies. DEC Vax version -;;; -;;; Matches version 4.2 of bobcat/assmd.scm -;;; (declare (usual-integrations)) -(declare (integrate addressing-granularity - scheme-object-width - endianness - maximum-padding-length - maximum-block-offset - block-offset-width) - (integrate-operator block-offset->bit-string - instruction-initial-position - instruction-insert!)) +(let-syntax ((fold + (macro (expression) + (eval expression system-global-environment)))) -(define addressing-granularity 8) -(define scheme-object-width 32) -(define endianness 'LITTLE) +(define-integrable addressing-granularity 8) +(define-integrable scheme-object-width 32) +(define-integrable endianness 'LITTLE) -;; Instructions can be any number of bytes long. -;; Thus the maximum padding is 3 bytes. -;; Pad with HALT instructions +(define-integrable maximum-padding-length + ;; Instructions can be any number of bytes long. + ;; Thus the maximum padding is 3 bytes. + 24) -(define maximum-padding-length 24) +(define-integrable padding-string + ;; Pad with HALT instructions + (fold (unsigned-integer->bit-string 8 #x00))) -(define padding-string - (unsigned-integer->bit-string 8 #x00)) +(define-integrable block-offset-width + ;; Block offsets are encoded words + 16) -;; Block offsets are encoded words +(define maximum-block-offset + (fold (- (expt 2 15) 1))) -(define maximum-block-offset (- (expt 2 15) 1)) -(define block-offset-width 16) - -(define (block-offset->bit-string offset start?) - (declare (integrate offset start?)) +(define-integrable (block-offset->bit-string offset start?) (unsigned-integer->bit-string block-offset-width - (+ (* 2 offset) ; shift left + (+ (* 2 offset) (if start? 0 1)))) -(define make-nmv-header - (let ((nmv-type-string - (unsigned-integer->bit-string 8 - (microcode-type 'MANIFEST-NM-VECTOR)))) - (named-lambda (make-nmv-header n) - (bit-string-append - (unsigned-integer->bit-string 24 n) - nmv-type-string)))) +(define-integrable nmv-type-string + (fold (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR)))) + +(define (make-nmv-header n) + (bit-string-append (unsigned-integer->bit-string 24 n) nmv-type-string)) (define (object->bit-string object) (bit-string-append (unsigned-integer->bit-string 24 (primitive-datum object)) (unsigned-integer->bit-string 8 (primitive-type object)))) - -;;; Machine dependent instruction order -;; These depend on the mapping between instruction streams and bit strings. -;; Depending on the byte order of the machine, instruction streams will grow -;; "forwards" or "backwards". +;;; Machine dependent instruction order -(define (instruction-initial-position block) - (declare (integrate block)) +(define-integrable (instruction-initial-position block) + block ; ignored 0) (define (instruction-insert! bits block position receiver) - (declare (integrate receiver)) (let ((l (bit-string-length bits))) (bit-substring-move-right! bits 0 l block position) (receiver (+ position l)))) -(set! instruction-append bit-string-append) +(define-integrable instruction-append + bit-string-append) + +;;; end let-syntax +) \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/coerce.scm b/v7/src/compiler/machines/vax/coerce.scm index f64269823..45f5f3c94 100644 --- a/v7/src/compiler/machines/vax/coerce.scm +++ b/v7/src/compiler/machines/vax/coerce.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/coerce.scm,v 1.3 1987/08/24 14:32:51 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/coerce.scm,v 1.4 1989/05/17 20:28:04 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, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -52,21 +53,21 @@ MIT in each case. |# (error "Short label out of range" offset))))) ;; *** NOTE *** -;; If you add coercions here, remember to also add them to -;; EXPAND-DESCRIPTOR in isnmac.scm . +;; If you add coercions here, remember to also add them in "insmac.scm". (define make-coercion (coercion-maker `((UNSIGNED . ,coerce-unsigned-integer) (SIGNED . ,coerce-signed-integer)))) -(define-coercion 'UNSIGNED 2) -(define-coercion 'UNSIGNED 4) -(define-coercion 'UNSIGNED 6) -(define-coercion 'UNSIGNED 8) -(define-coercion 'UNSIGNED 16) -(define-coercion 'UNSIGNED 32) +(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2)) +(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4)) +(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6)) +(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8)) +(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-coercion 'SIGNED 8) -(define-coercion 'SIGNED 16) -(define-coercion 'SIGNED 32) diff --git a/v7/src/compiler/machines/vax/dassm1.scm b/v7/src/compiler/machines/vax/dassm1.scm index e5dff9a92..8038a7b58 100644 --- a/v7/src/compiler/machines/vax/dassm1.scm +++ b/v7/src/compiler/machines/vax/dassm1.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm1.scm,v 4.1 1988/01/07 21:15:30 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm1.scm,v 4.2 1989/05/17 20:28:09 jinx Exp $ +$MC68020-Header: dassm1.scm,v 4.10 88/12/30 07:05:04 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,44 +33,100 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; VAX Disassembler -;;; -;;; Matches version 4.2 of bobcat/dassm1.scm -;;; +;;;; VAX 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 ((object (fasload (pathname-new-type pathname "com"))) + (info (let ((pathname (pathname-new-type pathname "binf"))) + (and (if (default-object? symbol-table?) + (file-exists? pathname) + symbol-table?) + (fasload pathname))))) + (cond ((compiled-code-address? object) + (disassembler/write-compiled-code-block + (compiled-code-address->block object) + info + false)) + ((not (scode/comment? object)) + (error "compiler:write-lap-file : Not a compiled file" + (pathname-new-type pathname "com"))) + (else + (scode/comment-components + object + (lambda (text expression) + expression ;; ignored + (if (dbg-info-vector? text) + (let ((items (dbg-info-vector/items text))) + (for-each disassembler/write-compiled-code-block + (vector->list items) + (if (false? info) + (make-list (vector-length items) false) + (vector->list info)))) + (error "compiler:write-lap-file : Not a compiled file" + (pathname-new-type pathname "com")))))))))))) +(define disassembler/base-address) + +(define (compiler:disassemble entry) + (let ((block (compiled-entry/block entry))) + (let ((info (compiled-code-block/dbg-info block))) + (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 (compiler:write-lap-file filename #!optional symbol-table?) - (let ((pathname (->pathname filename))) - (with-output-to-file (pathname-new-type pathname "lap") - (lambda () - (disassembler/write-compiled-code-block - (compiled-code-block/read-file (pathname-new-type pathname "com")) - (let ((pathname (pathname-new-type pathname "binf"))) - (and (if (unassigned? symbol-table?) - (file-exists? pathname) - symbol-table?) - (compiler-info/symbol-table - (compiler-info/read-file pathname))))))))) - -(define (disassembler/write-compiled-code-block block symbol-table) - (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)) +(define (write-block block) + (write-string "#[COMPILED-CODE-BLOCK ") + (write-string + (number->string (object-hash block) '(HEUR (RADIX D S)))) + (write-string " ") + (write-string + (number->string (object-datum block) '(HEUR (RADIX X E)))) + (write-string "]")) + +(define (disassembler/write-compiled-code-block block info #!optional page?) + (let ((symbol-table (dbg-info/labels info))) + (if (or (default-object? page?) page?) + (begin + (write-char #\page) + (newline))) + (write-string "Disassembly of ") + (write-block 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 @@ -79,7 +136,7 @@ MIT in each case. |# (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 @@ -103,55 +160,146 @@ MIT in each case. |# (procedure offset instruction) (loop (instruction-stream))))))) -(define disassembler/write-constants-block) -(let () - -(set! disassembler/write-constants-block - (named-lambda (disassembler/write-constants-block block symbol-table) - (fluid-let ((*unparser-radix* 16)) - (let ((end (system-vector-size block))) - (let loop ((index (compiled-code-block/constants-start block))) - (if (< index end) - (begin - (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 (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))) - (if (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 (string-downcase label)) - (write offset)))) - (write-string ")")))))) + (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 (string-downcase label)) + (write offset)))) + (write-string ")"))))) + ((compiled-code-address? constant) + (write-string " (offset ") + (write (compiled-code-address->offset constant)) + (write-string " in ") + (write-block (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 "]"))) + (case kind + ((0) + (write-caches + (1+ index) + compiled-code-block/objects-per-procedure-cache + (quotient length compiled-code-block/objects-per-procedure-cache) + disassembler/write-procedure-cache)) + ((1) + (write-caches + (1+ index) + compiled-code-block/objects-per-variable-cache + (quotient length compiled-code-block/objects-per-variable-cache) + (lambda (block index) + (disassembler/write-variable-cache "Reference" block index)))) + ((2) + (write-caches + (1+ index) + compiled-code-block/objects-per-variable-cache + (quotient length compiled-code-block/objects-per-variable-cache) + (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 - (sorted-vector/for-each symbol-table offset - (lambda (label) - (write-char #\Tab) - (write-string (string-downcase (label-info-name label))) - (write-char #\:) - (newline)))) + (let ((label (dbg-labels/find-offset symbol-table offset))) + (if label + (begin + (write-char #\Tab) + (write-string (string-downcase (dbg-label/name label))) + (write-char #\:) + (newline))))) + + (if disassembler/write-addresses? + (begin + (write-string + (number->string (+ offset disassembler/base-address) + '(HEUR (RADIX X S)))) + (write-char #\Tab))) + (if disassembler/write-offsets? - (begin (write-string - ((access unparse-number-heuristically number-unparser-package) - offset 16 false false)) - (write-char #\Tab))) + (begin + (write-string (number->string offset '(HEUR (RADIX X S)))) + (write-char #\Tab))) + (if symbol-table (write-string " ")) (write-instruction) diff --git a/v7/src/compiler/machines/vax/dassm2.scm b/v7/src/compiler/machines/vax/dassm2.scm index 2d79317c3..bd085bafd 100644 --- a/v7/src/compiler/machines/vax/dassm2.scm +++ b/v7/src/compiler/machines/vax/dassm2.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm2.scm,v 4.5 1988/03/21 21:42:02 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm2.scm,v 4.6 1989/05/17 20:28:17 jinx Exp $ +$MC68020-Header: dassm2.scm,v 4.12 88/12/30 07:05:13 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -35,14 +36,69 @@ MIT in each case. |# ;;;; VAX Disassembler: Top Level (declare (usual-integrations)) - + (set! compiled-code-block/bytes-per-object 4) +(set! compiled-code-block/objects-per-procedure-cache 2) +(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))) + (let ((opcode (read-unsigned-integer offset 16)) + (arity (read-unsigned-integer (+ offset 6) 16))) + (case opcode + ((#x9f17) ; JMP @# + (vector 'COMPILED + (read-procedure (+ offset 2)) + arity)) + ((#x9f16) ; JSB @# + (let* ((new-block + (compiled-code-address->block + (read-procedure (+ offset 2)))) + (offset + (fluid-let ((*block new-block)) + (read-unsigned-integer 14 16)))) + (case offset + ((#x106) ; lookup + (vector 'VARIABLE + (variable-cache-name + (system-vector-ref new-block 3)) + arity)) + ((#x10c) ; interpreted + (vector 'INTERPRETED + (system-vector-ref new-block 3) + arity)) + ((#x112 ; arity + #x11e ; entity + #x124 #x12a #x130 #x136 #x13c ; specialized arity + #x142 #x148 #x14e #x154 #x15e) + (vector 'COMPILED + (system-vector-ref new-block 3) + arity)) + (else ; including #x118, APPLY + (error + "disassembler/read-procedure-cache: Unknown offset" + offset block index))))) + (else + (error "disassembler/read-procedure-cache: Unknown opcode" + opcode block index)))))))) + (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)) + (if (and end-offset (< offset end-offset)) (disassemble-one-instruction block offset symbol-table state (lambda (offset* instruction state) (make-instruction offset @@ -67,38 +123,24 @@ MIT in each case. |# (define *block) (define *current-offset) (define *symbol-table) -(define *ir) (define *valid?) (define (disassemble-one-instruction block offset symbol-table state receiver) - (define (make-losing-instruction *ir size) - (case size - ((B) - `(DC B ,(bit-string->unsigned-integer *ir))) - ((W) - `(DC W ,(bit-string->unsigned-integer - (bit-string-append *ir (get-byte))))) - ((L) - `(DC L ,(bit-string->unsigned-integer - (bit-string-append (bit-string-append *ir (get-byte)) - (get-word))))))) - (fluid-let ((*block block) (*current-offset offset) (*symbol-table symbol-table) - (*ir) (*valid? true)) (let ((instruction (let ((byte (get-byte))) (if (external-label-marker? symbol-table offset state) - (make-losing-instruction byte 'W) + (make-data-deposit byte 'W) (let ((instruction ((vector-ref opcode-dispatch (bit-string->unsigned-integer byte))))) (if *valid? instruction - (make-losing-instruction byte 'B))))))) + (make-data-deposit byte 'B))))))) (receiver *current-offset instruction (disassembler/next-state instruction state))))) @@ -107,55 +149,82 @@ MIT in each case. |# 'INSTRUCTION-NEXT) (define (disassembler/next-state instruction state) + state ; ignored (if (and disassembler/compiled-code-heuristics? (or (memq (car instruction) '(BR JMP RSB)) (and (eq? (car instruction) 'JSB) (let ((entry (interpreter-register? (cadr instruction)))) (and entry - (eq? (car entry) 'ENTRY) - (not (eq? (cadr entry) 'SETUP-LEXPR))))))) + (eq? (car entry) 'ENTRY)))))) 'EXTERNAL-LABEL 'INSTRUCTION)) (set! disassembler/lookup-symbol (lambda (symbol-table offset) (and symbol-table - (let ((label (sorted-vector/find-element symbol-table offset))) + (let ((label (dbg-labels/find-offset symbol-table offset))) (and label - (label-info-name label)))))) + (dbg-label/name label)))))) (define (external-label-marker? symbol-table offset state) (if symbol-table - (sorted-vector/there-exists? symbol-table - (+ offset 2) - label-info-external?) + (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 2))) + (let loop ((offset (+ offset 4))) (let ((contents (read-bits (- offset 2) 16))) (if (bit-string-clear! contents 0) (let ((offset - (- offset (bit-string->unsigned-integer contents)))) + (- offset + (/ (bit-string->unsigned-integer contents) 2)))) (and (positive? offset) (loop offset))) - (= offset (bit-string->unsigned-integer contents)))))))) + (= offset + (/ (bit-string->unsigned-integer contents) 2)))))))) + +(define (make-data-deposit *ir size) + (case size + ((B) + `(BYTE ,(bit-string->unsigned-integer *ir))) + ((W) + `(WORD ,(bit-string->unsigned-integer + (bit-string-append *ir (get-byte))))) + ((L) + `(LONG ,(bit-string->unsigned-integer + (bit-string-append (bit-string-append *ir (get-byte)) + (get-word))))))) + +(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 (make-dc wl bit-string) - `(DC ,wl ,(bit-string->unsigned-integer bit-string))) +(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))) - (with-interrupt-mask interrupt-mask-none - (lambda (old) - (read-bits! (if *block - (+ (primitive-datum *block) offset) - offset) - 0 - word))) + (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)) ;;;; Compiler specific information + (define-integrable (lookup-special-register reg table) (assq reg table)) @@ -185,7 +254,7 @@ MIT in each case. |# (12 . FREE-POINTER) (13 . REGS-POINTER) (14 . STACK-POINTER) - (15 . PC))) + (15 . PROGRAM-COUNTER))) (define (make-offset deferred? register size offset) (let ((key (if deferred? '@@RO '@RO))) @@ -220,9 +289,6 @@ MIT in each case. |# ((REGISTER TEMPORARY ENTRY) effective-address) (else false)))) -(define interpreter-register-pointer - 6) - (define interpreter-register-assignments (let () (define (make-entries index names) @@ -237,25 +303,28 @@ MIT in each case. |# (12 . (REGISTER ENVIRONMENT)) (16 . (REGISTER TEMPORARY)) (20 . (REGISTER INTERPRETER-CALL-RESULT:ENCLOSE)) + (24 . (REGISTER RETURN-CODE)) + (28 . (REGISTER LEXPR-PRIMITIVE-ACTUALS)) + (32 . (REGISTER MINIMUM-LENGTH)) + (36 . (REGISTER PRIMITIVE)) + ;; Interface entry points + ,@(make-entries + #x0280 + '(link error apply + lexpr-apply primitive-apply primitive-lexpr-apply + cache-reference-apply lookup-apply + interrupt-continuation interrupt-ic-procedure + interrupt-procedure interrupt-closure + lookup safe-lookup set! access unassigned? unbound? define + reference-trap safe-reference-trap assignment-trap + unassigned?-trap + &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?)) ;; Compiler temporaries - ,@(let loop ((index 40) (i 0)) - (if (= i 50) + ,@(let loop ((index -4) (i 0)) + (if (>= i 512) '() (cons `(,index . (TEMPORARY ,i)) - (loop (+ index 4) (1+ i))))) - ;; Interpreter entry points - ,@(make-entries - #x00F0 - '(return-to-interpreter - uuo-link-trap operator-trap - apply error wrong-number-of-arguments - interrupt-procedure interrupt-continuation lookup-apply - lookup access unassigned? unbound? set! define primitive-apply enclose - setup-lexpr safe-lookup cache-variable reference-trap - assignment-trap uuo-link cache-reference-apply - safe-reference-trap unassigned?-trap cache-variable-multiple - uuo-link-multiple &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative? - cache-assignment cache-assignment-multiple primitive-lexpr-apply))))) + (loop (- index 4) (1+ i)))))))) (define (make-pc-relative deferred? size pco) @@ -270,13 +339,6 @@ MIT in each case. |# `(,(if deferred? '@@PCO '@PCO) ,size ,pco))) `(,(if deferred? '@@PCO '@PCO) ,size ,pco)))) -(define (offset->pc-relative pco reference-offset) - (if disassembler/symbolize-output? - `(@PCR ,(let ((absolute (+ pco reference-offset))) - (or (disassembler/lookup-symbol *symbol-table absolute) - absolute))) - `(@PCO ,pco))) - (define (undefined-instruction) ;; This losing assignment removes a 'cwcc'. Too bad. (set! *valid? false) diff --git a/v7/src/compiler/machines/vax/dassm3.scm b/v7/src/compiler/machines/vax/dassm3.scm index 7f6a21239..93ee845bd 100644 --- a/v7/src/compiler/machines/vax/dassm3.scm +++ b/v7/src/compiler/machines/vax/dassm3.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm3.scm,v 1.2 1988/01/18 18:39:49 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm3.scm,v 1.3 1989/05/17 20:28:24 jinx Rel $ +$MC68020-Header: dassm3.scm,v 4.6 88/08/29 22:40:41 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,19 +33,16 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; VAX Disassembler +;;;; VAX Disassembler: Internals (declare (usual-integrations)) -;;; Insides of the disassembler +;;;; Bit String Manipulation (define (make-fetcher size-in-bits) (let ((size-in-bytes (quotient size-in-bits 8))) (lambda () - (let ((word (bit-string-allocate size-in-bits))) - (with-interrupt-mask interrupt-mask-none - (lambda (old) - (read-bits! (+ (primitive-datum *block) *current-offset) 0 word))) + (let ((word (read-bits *current-offset size-in-bits))) (set! *current-offset (+ *current-offset size-in-bytes)) word)))) @@ -52,13 +50,13 @@ MIT in each case. |# (define get-word (make-fetcher 16)) (define get-longword (make-fetcher 32)) -(define (get-immediate-byte) +(define-integrable (get-immediate-byte) (extract+ (get-byte) 0 8)) -(define (get-immediate-word) +(define-integrable (get-immediate-word) (extract+ (get-word) 0 16)) -(define (get-immediate-longword) +(define-integrable (get-immediate-longword) (extract+ (get-longword) 0 32)) (define-integrable (extract bit-string start end) @@ -67,13 +65,93 @@ MIT in each case. |# (define-integrable (extract+ bit-string start end) (bit-string->signed-integer (bit-substring bit-string start end))) +;;;; Operand decoding + +(define operand-dispatch + (let ((short-literal + (lambda (*or* *os*) + *os* ; ignored + `(S ,(extract *or* 0 6)))) + (index-operand + (lambda (*or* *os*) + (let ((index-reg (extract *or* 0 4))) + `(X ,index-reg ,(decode-operand *os*))))) + (standard-operand + (lambda (if-reg if-pc) + (lambda (*or* *os*) + (let ((reg (extract *or* 0 4))) + (if (= #xF reg) + (if-pc *os*) + (if-reg reg)))))) + (simple-operand + (lambda (keyword) + (lambda (*or* *os*) + *os* ; ignored + `(,keyword ,(make-register (extract *or* 0 4))))))) + (let ((offset-operand + (lambda (deferred? size get) + (standard-operand + (lambda (reg) + (make-offset deferred? reg size (get))) + (lambda (*os*) + *os* ; ignored + (make-pc-relative deferred? size (get))))))) + (vector + short-literal ;0 short immediate + short-literal ;1 " " + short-literal ;2 " " + short-literal ;3 " " + index-operand ;4 indexed + (simple-operand 'R) ;5 register + (simple-operand '@R) ;6 register deferred + (simple-operand '@-R) ;7 autodecrement + (standard-operand ;8 autoincrement/immediate + (lambda (reg) + `(@R+ ,(make-register reg))) + (lambda (*os*) + `(& + ,(case *os* + ((B) (get-immediate-byte)) + ((W) (get-immediate-word)) + ((L) (get-immediate-longword)))))) + (standard-operand ;9 autoincrement deferred/absolute + (lambda (reg) + `(@@R+ ,(make-register reg))) + (lambda (*os*) + *os* ; ignored + `(@& , (extract+ (get-longword) 0 32)))) + (offset-operand false 'B ;a byte offset + get-immediate-byte) + (offset-operand true 'B ;b byte offset deferred + get-immediate-byte) + (offset-operand false 'W ;c word offset + get-immediate-word) + (offset-operand true 'W ;d word offset deferred + get-immediate-word) + (offset-operand false 'L ;e long offset + get-immediate-longword) + (offset-operand true 'L ;f long offset deferred + get-immediate-longword))))) + ;;;; Instruction decoding +(define (decode-operand size) + (let ((*or* (get-byte))) + ((vector-ref operand-dispatch (extract *or* 4 8)) + *or* size))) + +(define (decode-displacement size) + (case size + ((8) (make-pc-relative false 'B (get-immediate-byte))) + ((16) (make-pc-relative false 'W (get-immediate-word))) + ((32) (make-pc-relative false 'L (get-immediate-longword))) + (else (error "decode-displacement: bad size" size)))) + (define opcode-dispatch - (vector-cons 256 undefined-instruction)) + (make-vector 256 undefined-instruction)) (define secondary-opcode-dispatch - (vector-cons 256 undefined-instruction)) + (make-vector 256 undefined-instruction)) (define (define-standard-instruction opcode handler) (vector-set! opcode-dispatch opcode handler)) @@ -84,11 +162,26 @@ MIT in each case. |# (define-standard-instruction #xFD (lambda () ((vector-ref secondary-opcode-dispatch (get-immediate-byte))))) + +;; Most of the instructions decoders are generated from from the +;; assembler tables, but branch instructions are treated separately. -(define (define-branch-instruction opcode prefix size) - (define-standard-instruction opcode +(define (displacement-decoder size) + (define (make-decoder keyword getter) (lambda () - (append prefix (list (decode-displacement size)))))) + (make-pc-relative false keyword (getter)))) + + (case size + ((8) (make-decoder 'B get-immediate-byte)) + ((16) (make-decoder 'W get-immediate-word)) + ((32) (make-decoder 'L get-immediate-longword)) + (else (error "displacement-decoder: bad size" size)))) + +(define (define-branch-instruction opcode prefix size) + (let ((decoder (displacement-decoder size))) + (define-standard-instruction opcode + (lambda () + `(,@prefix ,(decoder)))))) ;; Conditional branches @@ -111,80 +204,4 @@ MIT in each case. |# (define-branch-instruction #x31 '(BR W) 16) (define-branch-instruction #x10 '(BSB B) 8) (define-branch-instruction #x30 '(BSB W) 16) - -;;;; Operand decoding -(define (decode-displacement size) - (case size - ((8) (make-pc-relative false 'B (get-immediate-byte))) - ((16) (make-pc-relative false 'W (get-immediate-word))) - ((32) (make-pc-relative false 'L (get-immediate-longword))) - (else (error "decode-displacement: bad size" size)))) - -(define (decode-operand size) - (let ((*or* (get-byte))) - ((vector-ref operand-dispatch (extract *or* 4 8)) - *or* size))) - -(define (short-literal *or* *os*) - `(S ,(extract *or* 0 6))) - -(define operand-dispatch - (vector-cons 16 short-literal)) - -(define (define-operand! mode handler) - (vector-set! operand-dispatch mode handler)) - -(define (define-standard-operand! mode if-reg if-pc) - (define-operand! mode - (lambda (*or* *os*) - (let ((reg (extract *or* 0 4))) - (if (= #xF reg) - (if-pc *os*) - (if-reg reg)))))) - -(define (define-simple-operand! mode keyword) - (define-operand! mode - (lambda (*or* *os*) - `(,keyword ,(make-register (extract *or* 0 4)))))) - -(define (define-offset-operand! mode deferred? size get) - (define-standard-operand! mode - (lambda (reg) - (make-offset deferred? reg size (get))) - (lambda (*os*) - (make-pc-relative deferred? size (get))))) - -;;;; Actual operand handlers (except short literal, above). - -(define-operand! 4 ;index mode - (lambda (*or* *os*) - (let ((index-reg (extract *or* 0 4))) - `(X ,index-reg ,(decode-operand *os*))))) - -(define-simple-operand! 5 'R) ;register -(define-simple-operand! 6 '@R) ;register deferred -(define-simple-operand! 7 '@-R) ;autodecrement - -(define-standard-operand! 8 ;autoincrement - (lambda (reg) - `(@R+ ,(make-register reg))) - (lambda (*os*) ;immediate - `(& - ,(case *os* - ((B) (get-immediate-byte)) - ((W) (get-immediate-word)) - ((L) (get-immediate-longword)))))) - -(define-standard-operand! 9 ;autoincrement deferred - (lambda (reg) - `(@@R+ ,(make-register reg))) - (lambda (*os*) ;absolute - `(@& , (extract+ (get-longword) 0 32)))) - -(define-offset-operand! 10 false 'B get-immediate-byte) -(define-offset-operand! 11 true 'B get-immediate-byte) -(define-offset-operand! 12 false 'W get-immediate-word) -(define-offset-operand! 13 true 'W get-immediate-word) -(define-offset-operand! 15 false 'L get-immediate-longword) -(define-offset-operand! 15 true 'L get-immediate-longword) diff --git a/v7/src/compiler/machines/vax/decls.scm b/v7/src/compiler/machines/vax/decls.scm index 3a01ba0ee..94f265b96 100644 --- a/v7/src/compiler/machines/vax/decls.scm +++ b/v7/src/compiler/machines/vax/decls.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/decls.scm,v 4.2 1988/02/23 19:29:53 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/decls.scm,v 4.3 1989/05/17 20:28:32 jinx Exp $ +$MC68020-Header: decls.scm,v 4.21 89/04/26 05:09:22 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,50 +33,93 @@ 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 +;;;; Compiler File Dependencies. VAX compiler. (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/vax")))) + (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 '()) - (rank false)) - -(define source-filenames - (mapcan (lambda (subdirectory) - (map (lambda (pathname) - (string-append subdirectory "/" (pathname-name pathname))) - (directory-read (string-append subdirectory "/*.scm")))) - '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt" - "machines/vax"))) - -(define source-hash - (make/hash-table 101 - string-hash-mod - (lambda (filename source-node) - (string=? filename (source-node/filename source-node))) - make/source-node)) - -(define source-nodes - (map (lambda (filename) - (hash-table/intern! source-hash - filename - identity-procedure - identity-procedure)) - source-filenames)) + (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 @@ -103,23 +147,12 @@ MIT in each case. |# (source-node/close! node dependency)) (source-node/forward-closure node))))) -(define (source-files-by-rank) - (source-nodes/rank! source-nodes) - (map source-node/filename (source-nodes/sort-by-rank source-nodes))) - -(define (source-files-with-circular-dependencies) - (map source-node/filename - (list-transform-positive source-nodes - (lambda (node) - (memq node (source-node/backward-closure node)))))) - -(define source-nodes/rank!) -(let () +;;;; Rank -(set! source-nodes/rank! - (lambda (nodes) - (compute-dependencies! nodes) - (compute-ranks! nodes))) +(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) @@ -127,7 +160,12 @@ MIT in each case. |# node (list-transform-negative (source-node/backward-closure node) (lambda (node*) - (memq node (source-node/backward-closure 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) @@ -152,263 +190,414 @@ MIT in each case. |# (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))))) -(define (file-dependency/syntax/join filenames dependency) - (for-each (lambda (filename) - (sf/set-file-syntax-table! filename dependency)) - filenames)) - -(define (define-integration-dependencies directory name directory* . names) - (file-dependency/integration/make (string-append directory "/" name) - (apply filename/append directory* names))) - -(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 (finish-integration-dependencies!) +;;;; 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? - (for-each (lambda (node) - (let ((links (source-node/backward-links node))) - (if (not (null? links)) - (sf/add-file-declarations! - (source-node/filename node) - `((INTEGRATE-EXTERNAL - ,@(map (lambda (node*) - (filename->absolute-pathname - (source-node/filename node*))) - links))))))) - source-nodes))) - -(define (file-dependency/expansion/join filenames expansions) - (if compiler:enable-expansion-declarations? - (for-each (lambda (filename) - (sf/add-file-declarations! - filename - `((EXPAND-OPERATOR ,@expansions)))) - filenames))) - -(define (filename/append directory . names) - (map (lambda (name) (string-append directory "/" name)) names)) + (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 (filename->absolute-pathname filename) - (pathname->absolute-pathname (->pathname filename))) +(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 -(file-dependency/syntax/join - (append (filename/append "base" - "blocks" "cfg1" "cfg2" "cfg3" "contin" "ctypes" - "debug" "enumer" "infgen" "infutl" "lvalue" "object" - "pmerly" "proced" "queue" "rvalue" "scode" "sets" - "subprb" "switch" "toplev" "utils") - (filename/append "back" - "asmmac" "bittop" "bitutl" "insseq" "lapgn1" "lapgn2" - "lapgn3" "linear" "regmap" "symtab" "syntax") - (filename/append "machines/vax" - "insmac" "machin" "rgspcm" "dassm1" "dassm2" "dassm3") - (filename/append "fggen" - "declar" "fggen") - (filename/append "fgopt" - "blktyp" "closan" "conect" "contan" "desenv" "folcon" - "offset" "operan" "order" "outer" "simapp" "simple") - (filename/append "rtlbase" - "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" "rtline" - "rtlobj" "rtlreg" "rtlty1" "rtlty2") - (filename/append "rtlgen" - "fndblk" "opncod" "rgcomb" "rgproc" "rgretn" "rgrval" - "rgstmt" "rtlgen") - (filename/append "rtlopt" - "ralloc" "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" - "rcsesr" "rdeath" "rdebug" "rlife")) - compiler-syntax-table) - -(file-dependency/syntax/join - (filename/append "machines/vax" - "lapgen" "rules1" "rules2" "rules3" "rules4") - lap-generator-syntax-table) - -(file-dependency/syntax/join - (filename/append "machines/vax" - "insutl" "instr1" "instr2" "instr3") - assembler-syntax-table) +(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" "switch" + "toplev" "utils") + (filename/append "back" + "asmmac" "bittop" "bitutl" "insseq" "lapgn1" + "lapgn2" "lapgn3" "linear" "regmap" "symtab" + "syntax") + (filename/append "machines/vax" + "dassm1" "dsyn" "insmac" "machin" "rgspcm") + (filename/append "fggen" + "declar" "fggen" "canon") + (filename/append "fgopt" + "blktyp" "closan" "conect" "contan" "delint" + "desenv" "envopt" "folcon" "offset" "operan" + "order" "outer" "param" "reord" "reuse" + "sideff" "simapp" "simple" "subfre") + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" + "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2") + (filename/append "rtlgen" + "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" + "rgretn" "rgrval" "rgstmt" "rtlgen") + (filename/append "rtlopt" + "ralloc" "rcse1" "rcse2" "rcseep" "rcseht" + "rcserq" "rcsesr" "rdeath" "rdebug" "rinvex" + "rlife")) + compiler-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/vax" + "lapgen" "rules1" "rules2" "rules3" "rules4" "rulfix") + lap-generator-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/vax" + "insutl" "instr1" "instr2" "instr3") + assembler-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/vax" + "dinstr1" "dinstr2" "dinstr3") + disassembler-syntax-table))) ;;;; Integration Dependencies -(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 "base" "infnew" "base" "infutl") - -(define-integration-dependencies "machines/vax" "dassm3" "machines/vax" "dassm1") -(define-integration-dependencies "machines/vax" "dassm3" "base" "infutl") -(define-integration-dependencies "machines/vax" "dassm2" "machines/vax" "dassm1") -(define-integration-dependencies "machines/vax" "dassm2" "base" "infutl") - -(define front-end-base - (filename/append "base" - "blocks" "cfg1" "cfg2" "cfg3" "contin" "ctypes" "enumer" - "lvalue" "object" "proced" "queue" "rvalue" "scode" - "subprb" "utils")) - -(define-integration-dependencies "machines/vax" "machin" "rtlbase" - "rtlreg" "rtlty1" "rtlty2") - -(define vax-base - (filename/append "machines/vax" "machin")) - -(define-integration-dependencies "rtlbase" "regset" "base") -(define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2") -(define-integration-dependencies "rtlbase" "rgraph" "machines/vax" "machin") -(define-integration-dependencies "rtlbase" "rtlcfg" "base" - "cfg1" "cfg2" "cfg3") -(define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils") -(define-integration-dependencies "rtlbase" "rtlcon" "machines/vax" "machin") -(define-integration-dependencies "rtlbase" "rtlexp" "base" "utils") -(define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" "rtlreg") -(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/vax" "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/vax" "machin") -(define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1") - -(define rtl-base - (filename/append "rtlbase" - "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" "rtlobj" - "rtlreg" "rtlty1" "rtlty2")) - -(file-dependency/integration/join - (append - (filename/append "fggen" - "declar" "fggen") - (filename/append "fgopt" - "blktyp" "closan" "conect" "contan" "desenv" "folcon" - "offset" "operan" "order" "outer" "simapp" "simple")) - (append front-end-base vax-base)) - -(file-dependency/integration/join - (filename/append "rtlgen" - "fndblk" "opncod" "rgcomb" "rgproc" "rgretn" "rgrval" - "rgstmt" "rtlgen") - (append front-end-base vax-base rtl-base)) - -(define cse-base - (filename/append "rtlopt" - "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr")) - -(file-dependency/integration/join - (append cse-base - (filename/append "rtlopt" "ralloc" "rdeath" "rdebug" "rlife")) - (append vax-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") - -(define instruction-base - (append (filename/append "back" "insseq") - (filename/append "machines/vax" "assmd" "machin"))) - -(define lapgen-base - (append (filename/append "back" "lapgn2" "lapgn3" "regmap") - (filename/append "machines/vax" "lapgen"))) - -(define assembler-base - (append (filename/append "back" "bitutl" "symtab") - (filename/append "machines/vax" "insutl"))) - -(define lapgen-body - (append - (filename/append "back" "lapgn1" "syntax") - (filename/append "machines/vax" "rules1" "rules2" "rules3" "rules4"))) - -(define assembler-body - (append - (filename/append "back" "bittop") - (filename/append "machines/vax" "instr1" "instr2" "instr3"))) - -(file-dependency/integration/join - (append instruction-base - lapgen-base - lapgen-body - assembler-base - assembler-body - (filename/append "back" "linear" "syerly")) - 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" "regmap" "base" "utils") -(define-integration-dependencies "back" "symtab" "base" "utils") +(define (initialize/integration-dependencies!) + (let ((front-end-base + (filename/append "base" + "blocks" "cfg1" "cfg2" "cfg3" + "contin" "ctypes" "enumer" "lvalue" + "object" "proced" "rvalue" + "scode" "subprb" "utils")) + (vax-base + (filename/append "machines/vax" "machin")) + (rtl-base + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlexp" "rtlobj" + "rtlreg" "rtlty1" "rtlty2")) + (cse-base + (filename/append "rtlopt" + "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr")) + (instruction-base + (append (filename/append "back" "insseq") + (filename/append "machines/vax" "assmd" "machin"))) + (lapgen-base + (append (filename/append "back" "lapgn2" "lapgn3" "regmap") + (filename/append "machines/vax" "lapgen"))) + (assembler-base + (append (filename/append "back" "bitutl" "symtab") + (filename/append "machines/vax" "insutl"))) + (lapgen-body + (append + (filename/append "back" "lapgn1" "syntax") + (filename/append "machines/vax" + "rules1" "rules2" "rules3" "rules4" "rulfix"))) + (assembler-body + (append + (filename/append "back" "bittop") + (filename/append "machines/vax" + "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/vax" "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/vax" + "machin") + (define-integration-dependencies "rtlbase" "rtlcfg" "base" + "cfg1" "cfg2" "cfg3") + (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils") + (define-integration-dependencies "rtlbase" "rtlcon" "machines/vax" + "machin") + (define-integration-dependencies "rtlbase" "rtlexp" "base" "utils") + (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" "rtlreg") + (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/vax" + "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/vax" + "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" "sideff" "simapp" "simple" "subfre")) + (append vax-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 vax-base front-end-base rtl-base)) + + (file-dependency/integration/join + (append cse-base + (filename/append "rtlopt" "ralloc" "rdeath" "rdebug" "rinvex" + "rlife")) + (append vax-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") + + (file-dependency/integration/join + (append instruction-base + lapgen-base + lapgen-body + assembler-base + assembler-body + (filename/append "back" "linear" "syerly")) + 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 -(file-dependency/expansion/join - (filename/append "machines/vax" - "lapgen" "rules1" "rules2" "rules3" "rules4" "insmac") - '((LAP:SYNTAX-INSTRUCTION - (ACCESS LAP:SYNTAX-INSTRUCTION-EXPANDER LAP-SYNTAX-PACKAGE - COMPILER-PACKAGE)) - (INSTRUCTION->INSTRUCTION-SEQUENCE - (ACCESS INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER LAP-SYNTAX-PACKAGE - COMPILER-PACKAGE)) - (SYNTAX-EVALUATION - (ACCESS SYNTAX-EVALUATION-EXPANDER LAP-SYNTAX-PACKAGE COMPILER-PACKAGE)) - (CONS-SYNTAX - (ACCESS CONS-SYNTAX-EXPANDER LAP-SYNTAX-PACKAGE COMPILER-PACKAGE)) - (EA-VALUE-EARLY - (ACCESS EA-VALUE-EXPANDER LAP-SYNTAX-PACKAGE COMPILER-PACKAGE)) - (COERCE-TO-TYPE - (ACCESS COERCE-TO-TYPE-EXPANDER LAP-SYNTAX-PACKAGE COMPILER-PACKAGE)))) - -(finish-integration-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/vax" + "lapgen" "rules1" "rules2" "rules3" "rules4" "rulfix") + (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) + ;; (COERCE-TO-TYPE-EARLY COERCE-TO-TYPE-EXPANDER) ; not used now + (EA-VALUE-EARLY EA-VALUE-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/vax/dsyn.scm b/v7/src/compiler/machines/vax/dsyn.scm index be624a30f..2dd04dcde 100644 --- a/v7/src/compiler/machines/vax/dsyn.scm +++ b/v7/src/compiler/machines/vax/dsyn.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dsyn.scm,v 1.5 1987/08/21 02:49:28 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dsyn.scm,v 1.6 1989/05/17 20:28:51 jinx Rel $ +This file has no counterpart in the MC68020 compiler -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,15 +39,20 @@ MIT in each case. |# ;;;; Instruction decoding -(define instructions-handled-specially '(DC BUG B BR BSB)) +(define (initialize-package!) + (syntax-table-define disassembler-syntax-table + 'DEFINE-INSTRUCTION + transform/define-instruction)) + +(define instructions-disassembled-specially + '(BYTE WORD LONG BUG B BR BSB)) (define disassembler-syntax-table (make-syntax-table system-global-syntax-table)) -(syntax-table-define disassembler-syntax-table - 'DEFINE-INSTRUCTION +(define transform/define-instruction (macro (name . cases) - (if (memq name instructions-handled-specially) + (if (memq name instructions-disassembled-specially) ''() `(begin ,@(map (lambda (case) (process-instruction-definition name case)) diff --git a/v7/src/compiler/machines/vax/inerly.scm b/v7/src/compiler/machines/vax/inerly.scm index 23387fe53..33d558457 100644 --- a/v7/src/compiler/machines/vax/inerly.scm +++ b/v7/src/compiler/machines/vax/inerly.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/inerly.scm,v 1.4 1987/08/23 16:32:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/inerly.scm,v 1.5 1989/05/17 20:29:02 jinx Rel $ +$MC68020-Header: inerly.scm,v 1.6 88/08/31 06:00:59 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,31 +40,31 @@ MIT in each case. |# ;;;; Instruction macros (define early-instructions '()) +(define early-transformers '()) +(define early-ea-database '()) (syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION (macro (opcode . patterns) - `(set! early-instructions - (cons - (list ',opcode + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode ,@(map (lambda (pattern) - `(early-parse-rule + `(EARLY-PARSE-RULE ',(car pattern) - (lambda (pat vars) - (early-make-rule - pat - vars - (scode-quote + (LAMBDA (PAT VARS) + (EARLY-MAKE-RULE + PAT + VARS + (SCODE-QUOTE (instruction->instruction-sequence ,(parse-instruction (cadr pattern) (cddr pattern) true))))))) patterns)) - early-instructions)))) + EARLY-INSTRUCTIONS)))) ;;;; Transformers and utilities -(define early-transformers '()) - (define (define-early-transformer name transformer) (set! early-transformers (cons (cons name transformer) @@ -71,20 +72,21 @@ MIT in each case. |# (syntax-table-define early-syntax-table 'DEFINE-SYMBOL-TRANSFORMER (macro (name . assoc) - `(define-early-transformer ',name (make-symbol-transformer ',assoc)))) + `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-SYMBOL-TRANSFORMER ',assoc)))) ;; *** Is this right? *** (syntax-table-define early-syntax-table 'DEFINE-TRANSFORMER (macro (name value) - `(define-early-transformer ',name ,value))) + `(DEFINE-EARLY-TRANSFORMER ',name ,value))) (syntax-table-define early-syntax-table 'DEFINE-EA-TRANSFORMER (macro (name category type) - `(define-early-transformer ',name - (make-ea-transformer ',category ',type)))) + `(DEFINE-EARLY-TRANSFORMER ',name + (MAKE-EA-TRANSFORMER ',category ',type)))) (define (make-ea-transformer category type) + type ; ignored (make-database-transformer (mapcan (lambda (rule) (apply @@ -101,19 +103,19 @@ MIT in each case. |# (syntax-table-define early-syntax-table 'DEFINE-EA-DATABASE (macro rules - `(define early-ea-database - (list + `(SET! EARLY-EA-DATABASE + (LIST ,@(map (lambda (rule) (apply (lambda (pattern categories . fields) (let ((keyword (car pattern))) - `(early-parse-rule + `(EARLY-PARSE-RULE ',pattern - (lambda (pat vars) - (list pat - vars + (LAMBDA (PAT VARS) + (LIST PAT + VARS ',categories - (scode-quote + (SCODE-QUOTE (MAKE-EFFECTIVE-ADDRESS ',keyword ',categories @@ -125,8 +127,9 @@ MIT in each case. |# ;; The index 2 here is the argument number to MAKE-EFFECTIVE-ADDRESS. (define ea-value-expander - ((access scode->scode-expander package/expansion package/scode-optimizer) + (scode->scode-expander (lambda (operands if-expanded if-not-expanded) + if-not-expanded ; ignored (define (default) (if-expanded (scode/make-combination (scode/make-variable 'EA-VALUE) (cdr operands)))) @@ -150,11 +153,16 @@ MIT in each case. |# false '() '((INTEGRATE *IMMEDIATE-TYPE*)) - (list-ref operands 2)) + (scode/make-sequence + (list (scode/make-variable '*IMMEDIATE-TYPE*) + (list-ref operands 2)))) (list type))))))))))) +#| +;; Not used currently + (define coerce-to-type-expander - ((access scode->scode-expander package/expansion package/scode-optimizer) + (scode->scode-expander (lambda (operands if-expanded if-not-expanded) (define (handle coercion name) (if-expanded @@ -169,7 +177,6 @@ MIT in each case. |# (case (scode/constant-value (cadr operands)) ((b) (handle coerce-8-bit-signed 'coerce-8-bit-signed)) ((w) (handle coerce-16-bit-signed 'coerce-16-bit-signed)) - ((b) (handle coerce-32-bit-signed 'coerce-32-bit-signed)) + ((l) (handle coerce-32-bit-signed 'coerce-32-bit-signed)) (else (if-not-expanded))))))) - - +|# \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/insmac.scm b/v7/src/compiler/machines/vax/insmac.scm index abfe5c069..735a10f0c 100644 --- a/v7/src/compiler/machines/vax/insmac.scm +++ b/v7/src/compiler/machines/vax/insmac.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/insmac.scm,v 1.11 1987/08/24 21:20:47 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/insmac.scm,v 1.12 1989/05/17 20:29:15 jinx Rel $ +$MC68020-Header: insmac.scm,v 1.124 88/06/14 08:47:02 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,11 +39,13 @@ MIT in each case. |# ;;;; Effective addressing +(define ea-database-name + 'EA-DATABASE) + (syntax-table-define assembler-syntax-table 'DEFINE-EA-DATABASE (macro rules - `(DEFINE EA-DATABASE - ,(compile-database - rules + `(DEFINE ,ea-database-name + ,(compile-database rules (lambda (pattern actions) (let ((keyword (car pattern)) (categories (car actions)) @@ -138,7 +141,11 @@ MIT in each case. |# ((IMMEDIATE) (receiver `(CONS-SYNTAX - (COERCE-TO-TYPE ,(cadar fields) *IMMEDIATE-TYPE*) + (COERCE-TO-TYPE ,(cadar fields) + *IMMEDIATE-TYPE* + ,(and (cddar fields) + (eq? (caddar fields) + 'UNSIGNED))) ,tail) tail-size)) (else diff --git a/v7/src/compiler/machines/vax/instr1.scm b/v7/src/compiler/machines/vax/instr1.scm index 07f20d2b9..5e1877623 100644 --- a/v7/src/compiler/machines/vax/instr1.scm +++ b/v7/src/compiler/machines/vax/instr1.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/instr1.scm,v 1.5 1987/08/24 14:43:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/instr1.scm,v 1.6 1989/05/17 20:29:48 jinx Rel $ +$MC68020-Header: instr1.scm,v 1.66 88/06/14 08:47:12 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -75,17 +76,25 @@ opcodes are (() (BYTE (8 ,opcode))))) -;; Pseudo-op +;; Pseudo ops -(define-instruction DC - ((B (? value)) +(define-instruction BYTE + ((S (? value)) (BYTE (8 value SIGNED))) + ((U (? value)) + (BYTE (8 value UNSIGNED)))) - ((W (? value)) +(define-instruction WORD + ((S (? value)) (BYTE (16 value SIGNED))) - - ((L (? value)) - (BYTE (32 value SIGNED)))) + ((U (? value)) + (BYTE (16 value UNSIGNED)))) + +(define-instruction LONG + ((S (? value)) + (BYTE (32 value SIGNED))) + ((U (? value)) + (BYTE (32 value UNSIGNED)))) ;;; Privilleged and miscellaneous (Chap. 10) diff --git a/v7/src/compiler/machines/vax/instr2.scm b/v7/src/compiler/machines/vax/instr2.scm index 7af34c6b1..7688737a9 100644 --- a/v7/src/compiler/machines/vax/instr2.scm +++ b/v7/src/compiler/machines/vax/instr2.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/instr2.scm,v 1.4 1987/08/20 19:33:30 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/instr2.scm,v 1.5 1989/05/17 20:29:54 jinx Rel $ +$MC68020-Header: instr2.scm,v 1.16 88/10/20 16:11:07 GMT markf Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and diff --git a/v7/src/compiler/machines/vax/instr3.scm b/v7/src/compiler/machines/vax/instr3.scm index 7ef5b0bb4..a27ddeea2 100644 --- a/v7/src/compiler/machines/vax/instr3.scm +++ b/v7/src/compiler/machines/vax/instr3.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/instr3.scm,v 1.7 1987/08/24 15:01:13 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/instr3.scm,v 1.8 1989/05/17 20:30:03 jinx Rel $ +$MC68020-Header: instr3.scm,v 1.16 88/10/04 23:04:57 GMT jinx Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -666,9 +667,9 @@ MIT in each case. |# ;; ;; (CASE B (R 0) (& 5) (& 2)) ;; (LABEL case-begin) -;; (DC W `(- case-5 case-begin)) -;; (DC W `(- case-6 case-begin)) -;; (DC W `(- case-7 case-begin)) +;; (WORD `(- case-5 case-begin)) +;; (WORD `(- case-6 case-begin)) +;; (WORD `(- case-7 case-begin)) ;; (define-instruction CASE diff --git a/v7/src/compiler/machines/vax/insutl.scm b/v7/src/compiler/machines/vax/insutl.scm index ebca24993..c61336c24 100644 --- a/v7/src/compiler/machines/vax/insutl.scm +++ b/v7/src/compiler/machines/vax/insutl.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/insutl.scm,v 4.1 1988/02/23 19:34:34 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/insutl.scm,v 4.2 1989/05/17 20:30:11 jinx Rel $ +$MC68020-Header: insutl.scm,v 1.6 88/06/14 08:47:30 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,9 +39,10 @@ MIT in each case. |# ;;;; Effective Addressing -;;; NOTE: If this format changes, inerly.scm may also need to be changed! +;;; *** NOTE: If this format changes, inerly.scm must also be changed! *** -(define ea-tag 'Effective-Address) +(define ea-tag + "Effective-Address") (define (make-effective-address keyword categories value) (vector ea-tag keyword categories value)) @@ -58,6 +60,17 @@ MIT in each case. |# (define-integrable (ea-value ea) (vector-ref ea 3)) + +;; For completeness + +(define (ea-keyword-early ea) + (vector-ref ea 1)) + +(define (ea-categories-early ea) + (vector-ref ea 2)) + +(define (ea-value-early ea) + (vector-ref ea 3)) ;;;; Addressing modes @@ -140,6 +153,12 @@ MIT in each case. |# (4 8)) (IMMEDIATE value)) + ((&U (? value)) ;Kludge + (R M W A V I) + (BYTE (4 15) + (4 8)) + (IMMEDIATE value UNSIGNED)) + ((@& (? value)) ; Absolute (R M W A V I) (BYTE (4 15) @@ -233,16 +252,18 @@ MIT in each case. |# ((effective-address? expression) expression) (else #F))))) -(define (coerce-to-type expression type) - (syntax-evaluation - expression - (case type - ((b) coerce-8-bit-signed) - ((w) coerce-16-bit-signed) - ((l) coerce-32-bit-signed) - ((d f g h l o q) - (error "coerce-to-type: Unimplemented type" type)) - (else (error "coerce-to-type: Unknown type" type))))) +(define (coerce-to-type expression type #!optional unsigned?) + (let ((unsigned? (and (not (default-object? unsigned?)) + unsigned?))) + (syntax-evaluation + expression + (case type + ((B) (if unsigned? coerce-8-bit-unsigned coerce-8-bit-signed)) + ((W) (if unsigned? coerce-16-bit-unsigned coerce-16-bit-signed)) + ((L) (if unsigned? coerce-32-bit-unsigned coerce-32-bit-signed)) + ((d f g h l o q) + (error "coerce-to-type: Unimplemented type" type)) + (else (error "coerce-to-type: Unknown type" type)))))) ;;; Transformers @@ -256,16 +277,6 @@ MIT in each case. |# (GTR . #x5) (LEQ . #x4) (GEQ . #x9) (LSS . #x8) (GTRU . #xB) (LEQU . #xA) (VC . #xD) (VS . #xC) (GEQU . #xF) (CC . #xF) (LSSU . #xE) (CS . #xE)) -;(define-symbol-transformer cc -; (NEQ #x2) (NEQU #x2) (EQL #x3) (EQLU #x3) -; (GTR #x4) (LEQ #x5) (GEQ #x8) (LSS #x9) (GTRU #xA) (LEQU #xB) -; (VC #xC) (VS #xD) (GEQU #xE) (CC #xE) (LSSU #xF) (CS #xF)) - -;(define-symbol-transformer inverse-cc -; (NEQ #x3) (NEQU #x3) (EQL #x2) (EQLU #x2) -; (GTR #x5) (LEQ #x4) (GEQ #x9) (LSS #x8) (GTRU #xB) (LEQU #xA) -; (VC #xD) (VS #xC) (GEQU #xF) (CC #xF) (LSSU #xE) (CS #xE)) - (define-transformer displacement (lambda (expression) (and (pair? expression) diff --git a/v7/src/compiler/machines/vax/lapgen.scm b/v7/src/compiler/machines/vax/lapgen.scm index 6e8dea30f..dad10afaf 100644 --- a/v7/src/compiler/machines/vax/lapgen.scm +++ b/v7/src/compiler/machines/vax/lapgen.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/lapgen.scm,v 4.5 1988/02/12 19:40:21 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/lapgen.scm,v 4.6 1989/05/17 20:30:17 jinx Exp $ +$MC68020-Header: lapgen.scm,v 4.19 89/01/18 13:49:56 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,16 +34,17 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Rules for DEC VAX. Part 1 -;;; Matches MC68020 version 1.188 -;;; -;;; Popper code has been removed, since poppers are -;;; no longer being used -;;; (declare (usual-integrations)) ;;;; Basic machine instructions +(define (reference->register-transfer source target) + (if (and (effective-address/register? source) + (= (lap:ea-R-register source) target)) + (LAP) + (LAP (MOV L ,source ,(register-reference target))))) + (define (register->register-transfer source target) (LAP ,(machine->machine-register source target))) @@ -58,9 +60,15 @@ MIT in each case. |# (define-integrable (machine->pseudo-register source target) (machine-register->memory source (pseudo-register-home target))) +;; Pseudo registers are at negative offsets from regs-pointer, +;; and each is two longwords long so it can hold a double float. + +(define-integrable (pseudo-register-offset register) + (* -2 (1+ (register-renumber register)))) + (define-integrable (pseudo-register-home register) (offset-reference regnum:regs-pointer - (+ #x000A (register-renumber register)))) + (pseudo-register-offset register))) (define-integrable (machine->machine-register source target) (INST (MOV L @@ -77,101 +85,115 @@ MIT in each case. |# ,source ,(register-reference target)))) -(define (offset-type offset) - (cond ((<= -128 offset 127) 'B) - ((<= -32768 offset 32767) 'W) +(define (datum-size datum) + (cond ((<= -128 datum 127) 'B) + ((<= -32768 datum 32767) 'W) (else 'L))) (define (offset-reference register offset) (if (zero? offset) (INST-EA (@R ,register)) (let ((real-offset (* 4 offset))) - (INST-EA (@RO ,(offset-type real-offset) ,register ,real-offset))))) + (INST-EA (@RO ,(datum-size real-offset) ,register ,real-offset))))) + +(define (byte-offset-reference register offset) + (if (zero? offset) + (INST-EA (@R ,register)) + (INST-EA (@RO ,(datum-size offset) ,register ,offset)))) ;; N is always unsigned. -;; Actually loaded as long (the popper code depends on this). -(define (load-rnw n r) +(define (load-rn n r) (cond ((zero? n) (INST (CLR L (R ,r)))) ((<= 0 n 63) - (INST (MOVZ B L (S ,n) (R ,r)))) + (INST (MOV L (S ,n) (R ,r)))) ((<= 0 n 127) (INST (MOVZ B L (& ,n) (R ,r)))) + ((<= 0 n 32767) + (INST (MOVZ W L (& ,n) (R ,r)))) (else - (INST (MOVZ W L (& ,n) (R ,r)))))) + (INST (MOV L (& ,n) (R ,r)))))) -(define (test-rnw n r) +(define (test-rn n r) (cond ((zero? n) - (INST (TST W (R ,r)))) + (INST (TST L (R ,r)))) ((<= 0 n 63) - (INST (CMP W (R ,r) (S ,n)))) + (INST (CMP L (R ,r) (S ,n)))) (else - (INST (CMP W (R ,r) (& ,n)))))) + (INST (CMP L (R ,r) (& ,n)))))) -(define (increment-rnl rn n) +(define (increment-rn rn n) (if (zero? n) (LAP) - (let ((offset (* 4 n))) - (cond ((<= 0 offset 63) - (LAP (ADD L (S ,offset) (R ,rn)))) - ((<= -63 offset 0) - (LAP (SUB L (S ,offset) (R ,rn)))) + (let ((value (* 4 n))) + (cond ((<= 0 value 63) + (LAP (ADD L (S ,value) (R ,rn)))) + ((<= -63 value 0) + (LAP (SUB L (S ,value) (R ,rn)))) (else - (LAP (MOVA L (@RO ,(offset-type offset) ,rn ,offset) - (R ,rn)))))))) + (let ((size (datum-size value))) + (if (not (eq? size 'L)) + (LAP (MOVA L (@RO ,size ,rn ,value) + (R ,rn))) + (LAP (ADD L (& ,value) (R ,rn)))))))))) +(define (constant->ea constant) + (if (non-pointer-object? constant) + (INST-EA (@PCR ,(constant->label constant))) + (non-pointer->ea (object-type constant) (object-datum constant)))) + +(define (non-pointer->ea type datum) + (cond ((not (zero? type)) + (INST-EA (& ,(make-non-pointer-literal type datum)))) + ((<= 0 datum 63) + (INST-EA (S ,datum))) + (else + (INST-EA (& ,datum))))) + (define (push-constant constant) (if (non-pointer-object? constant) - (push-non-pointer (primitive-type constant) - (primitive-datum constant)) + (push-non-pointer (object-type constant) + (object-datum constant)) (INST (PUSHL (@PCR ,(constant->label constant)))))) (define (push-non-pointer type datum) (cond ((not (zero? type)) (INST (PUSHL (& ,(make-non-pointer-literal type datum))))) - ((zero? datum) - (INST (CLR L (@-R 14)))) ((<= 0 datum 63) (INST (PUSHL (S ,datum)))) (else - (INST (CVT ,(offset-type datum) L (& ,datum) (@-R 14)))))) + (let ((size (datum-size datum))) + (if (not (eq? size 'L)) + (INST (CVT ,size L (& ,datum) (@-R 14))) + (INST (PUSHL (& ,datum)))))))) (define (load-constant constant target) (if (non-pointer-object? constant) - (load-non-pointer (primitive-type constant) - (primitive-datum constant) + (load-non-pointer (object-type constant) + (object-datum constant) target) (INST (MOV L (@PCR ,(constant->label constant)) ,target)))) (define (load-non-pointer type datum target) - (cond ((not (zero? type)) - (INST (MOV L - (& ,(make-non-pointer-literal type datum)) - ,target))) - ((zero? datum) + (if (not (zero? type)) + (INST (MOV L + (& ,(make-non-pointer-literal type datum)) + ,target)) + (load-immediate datum target))) + +(define (load-immediate datum target) + (cond ((zero? datum) (INST (CLR L ,target))) ((<= 0 datum 63) (INST (MOV L (S ,datum) ,target))) (else - (INST (CVT ,(offset-type datum) L (& ,datum) ,target))))) - -(define (test-non-pointer type datum effective-address) - ;; *** These may be backwards *** - (cond ((not (zero? type)) - (INST (CMP L - (& ,(make-non-pointer-literal type datum)) - ,effective-address))) - ((zero? datum) - (INST (TST L ,effective-address))) - ((<= 0 datum 63) - (INST (CMP L (S ,datum) ,effective-address))) - (else - (INST (CMP L - (& ,(make-non-pointer-literal type datum)) - ,effective-address))))) + (let ((size (datum-size datum))) + (if (not (eq? size 'L)) + (INST (CVT ,size L (& ,datum) ,target)) + (INST (MOV L (& ,datum) ,target))))))) (define make-non-pointer-literal (let ((type-scale-factor (expt 2 24))) @@ -183,11 +205,24 @@ MIT in each case. |# (define (test-byte n effective-address) (cond ((zero? n) (INST (TST B ,effective-address))) - ;; These may be backwards ((<= 0 n 63) - (INST (CMP B (S ,n) ,effective-address))) + (INST (CMP B ,effective-address (S ,n)))) (else - (INST (CMP B (& ,n) ,effective-address))))) + (INST (CMP B ,effective-address (& ,n)))))) + +(define (test-non-pointer type datum effective-address) + (cond ((not (zero? type)) + (INST (CMP L + ,effective-address + (& ,(make-non-pointer-literal type datum))))) + ((zero? datum) + (INST (TST L ,effective-address))) + ((<= 0 datum 63) + (INST (CMP L ,effective-address (S ,datum)))) + (else + (INST (CMP L + ,effective-address + (& ,(make-non-pointer-literal type datum))))))) (define (set-standard-branches! condition-code) (set-current-branches! @@ -208,55 +243,66 @@ MIT in each case. |# (GEQU . LSSU) (LSSU . GEQU))) (error "INVERT-CC: Not a known CC" condition-code)))) -(define (expression->machine-register! expression register) - (let ((target (register-reference register))) - (let ((result - (case (car expression) - ((REGISTER) - (LAP (MOV L ,(coerce->any (cadr expression)) ,target))) - ((OFFSET) - (LAP - (MOV L - ,(indirect-reference! (cadadr expression) - (caddr expression)) - ,target))) - ((CONSTANT) - (LAP ,(load-constant (cadr expression) target))) - ((UNASSIGNED) - (LAP ,(load-non-pointer type-code:unassigned 0 target))) - (else - (error "Unknown expression type" (car expression)))))) - (delete-machine-register! register) - result))) +(define (invert-cc-noncommutative condition-code) + ;; Despite the fact that the name of this procedure is similar to + ;; that of `invert-cc', it is quite different. `invert-cc' is used + ;; when the branches of a conditional are being exchanged, while + ;; this is used when the arguments are being exchanged. + (cdr (or (assq condition-code + '((NEQU . NEQU) (EQLU . EQLU) + (NEQ . NEQ) (EQL . EQL) + (GTR . LSS) (LSS . GTR) + (GEQ . LEQ) (LEQ . GEQ) + ;; *** Are these two really correct? *** + (VC . VC) (VS . VS) + (CC . CC) (CS . CS) + (GTRU . LSSU) (LSSU . GTRU) + (GEQU . LEQU) (LEQU . GEQU))) + (error "INVERT-CC-NONCOMMUTATIVE: Not a known CC" condition-code)))) + +(define-integrable (cc-commutative? condition-code) + (memq condition-code '(NEQ EQL NEQU EQLU VC VS CC CS))) + +(define-integrable (effective-address/register? ea) + (eq? (lap:ea-keyword ea) 'R)) + +(define-integrable (effective-address/register-indirect? ea) + (eq? (lap:ea-keyword ea) '@R)) + +(define-integrable (effective-address/register-offset? ea) + (eq? (lap:ea-keyword ea) '@RO)) -(define (indirect-reference! register offset) - (offset-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 happen only when the - ;; register block spills something. - (begin (warn "Needed to load indirect register!" register) - (load-alias-register! register 'GENERAL)))) - offset)) - -(define (coerce->any register) - (if (machine-register? register) - (register-reference register) - (let ((alias (register-alias register false))) - (if alias - (register-reference alias) - (pseudo-register-home register))))) +(define (standard-target-reference target) + (delete-dead-registers!) + (register-reference + (or (register-alias target 'GENERAL) + (allocate-alias-register! target 'GENERAL)))) -(define (coerce->machine-register register) - (if (machine-register? register) - (register-reference register) - (reference-alias-register! register false))) +(define-integrable (preferred-register-reference register) + (register-reference (preferred-register register))) + +(define (preferred-register register) + (or (register-alias register 'GENERAL) + (load-alias-register! register 'GENERAL))) -;; *** What is this? *** +(define (offset->indirect-reference! offset) + (indirect-reference! (rtl:register-number (rtl:offset-register offset)) + (rtl:offset-number offset))) + +(define-integrable (indirect-reference! register offset) + (offset-reference (allocate-indirection-register! register) offset)) + +(define-integrable (indirect-byte-reference! register offset) + (byte-offset-reference (allocate-indirection-register! register) offset)) + +(define (allocate-indirection-register! register) + (if (machine-register? register) + register + (preferred-register register))) (define (code-object-label-initialize code-object) + ;; *** What is this for? *** + code-object ; ignored false) (define (generate-n-times n limit instruction-gen with-counter) @@ -264,7 +310,7 @@ MIT in each case. |# (let ((loop (generate-label 'LOOP))) (with-counter (lambda (counter) - (LAP ,(load-rnw (-1+ n) counter) + (LAP ,(load-rn (-1+ n) counter) (LABEL ,loop) ,(instruction-gen) (SOB GEQ (R ,counter) (@PCR ,loop)))))) @@ -274,9 +320,129 @@ MIT in each case. |# (LAP ,(instruction-gen) ,@(loop (-1+ n))))))) +;;;; Expression-Generic Operations + +(define (expression->machine-register! expression register) + (let ((target (register-reference register))) + (let ((result + (case (car expression) + ((REGISTER) + (load-machine-register! (rtl:register-number expression) + register)) + ((OFFSET) + (LAP (MOV L ,(offset->indirect-reference! expression) ,target))) + ((CONSTANT) + (LAP ,(load-constant (rtl:constant-value expression) target))) + ((UNASSIGNED) + (LAP ,(load-non-pointer type-code:unassigned 0 target))) + (else + (error "Unknown expression type" (car expression)))))) + (delete-machine-register! register) + result))) + +(define (make-immediate value) + (if (<= 0 value 63) + (INST-EA (S ,value)) + (INST-EA (& ,value)))) + +(define (bump-type ea) + (cond ((effective-address/register-indirect? ea) + (INST-EA (@RO B ,(lap:ea-@R-register ea) 3))) + ((effective-address/register-offset? ea) + (let ((offset (+ 3 (lap:ea-@RO-offset ea)))) + (INST-EA (@RO ,(datum-size offset) + ,(lap:ea-@RO-register ea) + ,offset)))) + (else #F))) + +(define (put-type-in-ea type-code ea) + (cond ((not (effective-address/register? ea)) + (let ((target (bump-type ea))) + (if target + (LAP (MOV B ,(make-immediate type-code) ,target)) + (error "PUT-TYPE-IN-EA: Illegal effective address" ea)))) + ((zero? type-code) + (LAP (BIC L ,mask-reference ,ea))) + (else + (LAP (BIC L ,mask-reference ,ea) + (BIS L (& ,(make-non-pointer-literal type-code 0)) ,ea))))) + +(define (standard-target-expression? target) + (or (rtl:offset? target) + (rtl:free-push? target) + (rtl:stack-push? target))) + +(define (rtl:free-push? expression) + (and (rtl:post-increment? expression) + (interpreter-free-pointer? (rtl:post-increment-register expression)) + (= 1 (rtl:post-increment-number expression)))) + +(define (rtl:stack-push? expression) + (and (rtl:pre-increment? expression) + (interpreter-stack-pointer? (rtl:pre-increment-register expression)) + (= -1 (rtl:pre-increment-number expression)))) + +(define (standard-target-expression->ea target) + (cond ((rtl:offset? target) (offset->indirect-reference! target)) + ((rtl:free-push? target) (INST-EA (@R+ 12))) + ((rtl:stack-push? target) (INST-EA (@-R 14))) + (else (error "STANDARD-TARGET->EA: Not a standard target" target)))) + +;; Fixnum stuff moved to rulfix.scm + +;;;; Datum and character utilities + +#| +;;; OBJECT->DATUM rules - Mhwu + +;; These seem unused. + +(define (load-constant-datum constant register-ref) + (if (non-pointer-object? constant) + (load-non-pointer 0 (object-datum constant) ,register-ref) + (LAP (MOV L + (@PCR ,(constant->label constant)) + ,register-ref) + ,@(object->address register-ref)))) + +(define (byte-offset->register source source-reg target) + source-reg ; ignored + (delete-dead-registers!) + (let ((target (allocate-alias-register! target 'GENERAL))) + (LAP (MOVZ B L ,source ,(register-reference target))))) +|# + +;;; CHAR->ASCII rules + +(define (coerce->any/byte-reference register) + (if (machine-register? register) + (register-reference register) + (let ((alias (register-alias register false))) + (if alias + (register-reference alias) + (indirect-char/ascii-reference! + regnum:regs-pointer + (pseudo-register-offset register)))))) + +(define-integrable (indirect-char/ascii-reference! register offset) + (indirect-byte-reference! register (+ 3 (* offset 4)))) +(define (char->signed-8-bit-immediate character) + (let ((ascii (char->ascii character))) + (if (< ascii 128) + ascii + (- ascii 256)))) + +(define (indirect-register register) + (if (machine-register? register) + register + (register-alias register false))) + (define-integrable (lap:ea-keyword expression) (car expression)) +(define-integrable (lap:ea-R-register expression) + (cadr expression)) + (define-integrable (lap:ea-@R-register expression) (cadr expression)) @@ -293,13 +459,9 @@ MIT in each case. |# (INST (BR (@PCR ,label)))) ; Unsized (define-export (lap:make-entry-point label block-start-label) - (set! compiler:external-labels - (cons label compiler:external-labels)) + block-start-label (LAP (ENTRY-POINT ,label) - (BLOCK-OFFSET ,label) - (LABEL ,label))) - -;;;; Registers/Entries + ,@(make-external-label expression-code-word label))) (let-syntax ((define-entries (macro (start . names) @@ -312,37 +474,92 @@ MIT in each case. |# (INST-EA (@RO W 13 ,index))) (loop (cdr names) (+ index 6))))) `(BEGIN ,@(loop names start))))) - (define-entries #x00F0 return-to-interpreter uuo-link-trap operator-trap - apply error wrong-number-of-arguments - interrupt-procedure interrupt-continuation lookup-apply - lookup access unassigned? unbound? set! define primitive-apply enclose - setup-lexpr safe-lookup cache-variable reference-trap - assignment-trap uuo-link cache-reference-apply - safe-reference-trap unassigned?-trap cache-variable-multiple - uuo-link-multiple &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative? - cache-assignment cache-assignment-multiple primitive-lexpr-apply)) + (define-entries #x0280 + link error apply + lexpr-apply primitive-apply primitive-lexpr-apply + cache-reference-apply lookup-apply + interrupt-continuation interrupt-ic-procedure + interrupt-procedure interrupt-closure + lookup safe-lookup set! access unassigned? unbound? define + reference-trap safe-reference-trap assignment-trap unassigned?-trap + &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?)) (define-integrable reg:compiled-memtop (INST-EA (@R 13))) (define-integrable reg:environment (INST-EA (@RO B 13 #x0C))) (define-integrable reg:temp (INST-EA (@RO B 13 #x10))) -(define-integrable reg:enclose-result (INST-EA (@RO B 13 #x14))) -(define-integrable reg:lexpr-primitive-arity (INST-EA (@RO 6 #x001C))) - -;; These are the results of using bump-type on the corresponding values. -(define-integrable reg:temp-type (INST-EA (@RO B 13 #x13))) -(define-integrable reg:enclose-result-type (INST-EA (@RO B 13 #x17))) +(define-integrable reg:lexpr-primitive-arity (INST-EA (@RO B 13 #x1C))) -(define (bump-type effective-address) - (cond ((eq? (lap:ea-keyword effective-address) '@R) - (INST-EA (@RO B ,(lap:ea-@R-register effective-address) 3))) - ((eq? (lap:ea-keyword effective-address) '@RO) - (let ((offset (+ 3 (lap:ea-@RO-offset effective-address)))) - (INST-EA (@RO ,(offset-type offset) - ,(lap:ea-@RO-register effective-address) - ,offset)))) - (else #F))) - -(define (immediate-type type-code) - (if (<= 0 type-code 63) - (INST-EA (S ,type-code)) - (INST-EA (& ,type-code)))) +;;;; 2/3 Operand register allocation + +;; These should probably live in back/lapgn2.scm + +(define (with-copy-if-available source type if-win if-lose use-register!) + (reuse-pseudo-register-alias + source type + (lambda (reusable-alias) + (if-win (lambda () + (delete-machine-register! reusable-alias) + (delete-dead-registers!) + (use-register! reusable-alias) + (register-reference reusable-alias)))) + if-lose)) + +(define-integrable (with-register-copy-if-available + source type target if-win if-lose) + (with-copy-if-available source type if-win if-lose + (lambda (reusable-alias) + (add-pseudo-register-alias! target reusable-alias)))) + +(define-integrable (with-temporary-copy-if-available + source type if-win if-lose) + (with-copy-if-available source type if-win if-lose need-register!)) + +;;;; Higher level rules - assignment + +(define-integrable (convert-object/constant->register target constant + rtconversion + ctconversion) + (let ((target (standard-target-reference target))) + (if (non-pointer-object? constant) + (ctconversion constant target) + (rtconversion (constant->ea constant) target)))) + +(define-integrable (convert-object/register->register target source conversion) + ;; `conversion' often expands into multiple references to `target'. + (with-register-copy-alias! source 'GENERAL target + (lambda (target) + (conversion target target)) + conversion)) + +(define-integrable (convert-object/offset->register target address + offset conversion) + (let ((source (indirect-reference! address offset))) + (conversion source + (standard-target-reference target)))) + +;;;; Higher level rules - predicates + +(define (predicate/memory-operand? expression) + (or (rtl:offset? expression) + (and (rtl:post-increment? expression) + (interpreter-stack-pointer? + (rtl:post-increment-register expression))))) + +(define (predicate/memory-operand-reference expression) + (case (rtl:expression-type expression) + ((OFFSET) (offset->indirect-reference! expression)) + ((POST-INCREMENT) (INST-EA (@R+ 14))) + (else (error "Illegal memory operand" expression)))) + +(define (compare/register*register register-1 register-2 cc) + (set-standard-branches! cc) + (LAP (CMP L ,(standard-register-reference register-1 false) + ,(standard-register-reference register-2 false)))) + +(define (compare/register*memory register memory cc) + (set-standard-branches! cc) + (LAP (CMP L ,(standard-register-reference register false) ,memory))) + +(define (compare/memory*memory memory-1 memory-2 cc) + (set-standard-branches! cc) + (LAP (CMP L ,memory-1 ,memory-2))) \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/machin.scm b/v7/src/compiler/machines/vax/machin.scm index eccb4ff5a..ec433622e 100644 --- a/v7/src/compiler/machines/vax/machin.scm +++ b/v7/src/compiler/machines/vax/machin.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/machin.scm,v 4.4 1988/03/07 22:17:01 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/machin.scm,v 4.5 1989/05/17 20:30:31 jinx Rel $ +$MC68020-Header: machin.scm,v 4.14 89/01/18 09:58:56 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -35,62 +36,38 @@ MIT in each case. |# ;;;; Machine Model for DEC Vax (declare (usual-integrations)) - (define-integrable (stack->memory-offset offset) + ;;; Size of words. Some of the stuff in "assmd.scm" might want to +;;; come here. + +(define-integrable addressing-granularity 8) +(define-integrable scheme-object-width 32) +(define-integrable scheme-datum-width 24) +(define-integrable scheme-type-width 8) + +;; 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 address-units-per-object 4) +(define-integrable address-units-per-packed-char 1) + +(let-syntax ((fold + (macro (expression) + (eval expression system-global-environment)))) + (define-integrable unsigned-fixnum/upper-limit (fold (expt 2 24))) + (define-integrable signed-fixnum/upper-limit (fold (expt 2 23))) + (define-integrable signed-fixnum/lower-limit (fold (- (expt 2 23))))) + +(define-integrable (stack->memory-offset offset) offset) (define ic-block-first-parameter-offset 2) -(define (rtl:expression-cost expression) - ;; Returns an estimate of the cost of evaluating the expression. - ;; The number of cycles is processor dependent, and not published. - ;; Thus the number of bytes is used as the cost. - ;; In the following, temp, and temp+3 are assumed to qualify as byte - ;; offsets. - (case (rtl:expression-type expression) - ((ASSIGNMENT-CACHE VARIABLE-CACHE) 16) ;move.l d(pc),reg - ((CONS-POINTER) - ;; movl free,temp(regs) = 4 - ;; movb &type,3+temp(regs) = 4 (literal, rather than byte immediate) - ;; movl temp(regs),reg = 4 - (+ 12 - (rtl:expression-cost (rtl:cons-pointer-type expression)) - (rtl:expression-cost (rtl:cons-pointer-datum expression)))) - ((CONSTANT) - (let ((value (cadr expression))) - (cond ((false? value) 2) ;clrl reg - ((or (eq? value true) - (char? value) - (and (integer? value) - (<= -#x80000000 value #x7FFFFFFF))) - 7) ;movl #...,reg - (else 5)))) ;movl d(pc),reg (word offset) - ;; mova d(pc),reg = 5 (word offset) - ;; movl reg,temp(regs) = 4 - ;; movb &type,3+temp(regs) = 4 (literal, rather than byte immediate) - ;; movl temp(regs),reg = 4 - ((ENTRY:CONTINUATION ENTRY:PROCEDURE) 17) - ((OBJECT->ADDRESS OBJECT->DATUM) 6) ;bicl2 rmask,reg - ;; movl reg,temp(regs) = 4 - ;; movb temp+3(regs),reg = 4 - ((OBJECT->TYPE) 8) - ((OFFSET) 4) ;movl d(reg),reg (byte offset) - ((OFFSET-ADDRESS) 4) ;mova d(reg),reg (byte offset) - ((POST-INCREMENT) 3) ;movl (reg)+,reg - ((PRE-INCREMENT) 3) ;movl -(reg),reg - ((REGISTER) 3) ;movl reg,reg - ((UNASSIGNED) 7) ;movl #data,reg - ((VARIABLE-CACHE) 5) ;movl d(pc),reg (word offset) - (else (error "Unknown expression type" expression)))) - -;;; Machine registers - -(define-integrable interregnum:memory-top 0) -(define-integrable interregnum:stack-guard 1) -(define-integrable interregnum:value 2) -(define-integrable interregnum:environment 3) -(define-integrable interregnum:temporary 4) -(define-integrable interregnum:enclose 5) +(define closure-block-first-offset + 2) (define (rtl:machine-register? rtl-register) (case rtl-register @@ -108,18 +85,24 @@ MIT in each case. |# (define (rtl:interpreter-register? rtl-register) (case rtl-register - ((MEMORY-TOP) interregnum:memory-top) - ((STACK-GUARD) interregnum:stack-guard) - ((VALUE) interregnum:value) - ((ENVIRONMENT) interregnum:environment) - ((TEMPORARY) interregnum:temporary) - ((INTERPRETER-CALL-RESULT:ENCLOSE) interregnum:enclose) + ((MEMORY-TOP) 0) + ((STACK-GUARD) 1) + ((VALUE) 2) + ((ENVIRONMENT) 3) + ((TEMPORARY) 4) (else false))) (define (rtl:interpreter-register->offset locative) (or (rtl:interpreter-register? locative) (error "Unknown register type" locative))) +(define (rtl:constant-cost constant) + ;; Magic numbers. Ask RMS where they came from. + (if (and (object-type? 0 constant) + (zero? (object-datum constant))) + 0 + 3)) + (define-integrable r0 0) (define-integrable r1 1) (define-integrable r2 2) @@ -137,12 +120,8 @@ MIT in each case. |# (define-integrable r14 14) (define-integrable r15 15) (define number-of-machine-registers 16) - -(define-integrable (register-contains-address? register) - (memv register '(10 12 13 14 15))) - -(define initial-address-registers - (list r10 r12 r13 r14 r15)) +;; Each is a quadword long +(define number-of-temporary-registers 256) (define-integrable regnum:dynamic-link r10) (define-integrable regnum:free-pointer r12) @@ -155,27 +134,27 @@ MIT in each case. |# (define available-machine-registers (list r0 r1 r2 r3 r4 r5 r6 r7 r8 r9)) -(define-integrable (pseudo-register=? x y) - (= (register-renumber x) (register-renumber y))) - -;;; Interpreter registers - +(define initial-non-object-registers + (list r10 r11 r12 r13 r14 r15)) - -(define (register-type register) +(define-integrable (register-type register) + ;; This may have to be changed when floating support is added. 'GENERAL) (define register-reference (let ((references (make-vector 16))) (let loop ((i 0)) (if (< i 16) - (begin (vector-set! references i (INST-EA (R ,i))) - (loop (1+ i))))) + (begin + (vector-set! references i (INST-EA (R ,i))) + (loop (1+ i))))) (lambda (register) (vector-ref references register)))) (define mask-reference (INST-EA (R 11))) +;; These must agree with cmpvax.m4 + (define-integrable (interpreter-register:access) (rtl:make-machine-register r0)) @@ -185,9 +164,6 @@ MIT in each case. |# (define-integrable (interpreter-register:cache-unassigned?) (rtl:make-machine-register r0)) -(define-integrable (interpreter-register:enclose) - (rtl:make-offset (interpreter-regs-pointer) interregnum:enclose)) - (define-integrable (interpreter-register:lookup) (rtl:make-machine-register r0)) @@ -197,11 +173,21 @@ MIT in each case. |# (define-integrable (interpreter-register:unbound?) (rtl:make-machine-register r0)) -(define-integrable (interpreter-dynamic-link) - (rtl:make-machine-register regnum:dynamic-link)) +(define-integrable (interpreter-value-register) + (rtl:make-offset (interpreter-regs-pointer) 2)) -(define-integrable (interpreter-dynamic-link? register) - (= (rtl:register-number register) regnum:dynamic-link)) +(define (interpreter-value-register? expression) + (and (rtl:offset? expression) + (interpreter-regs-pointer? (rtl:offset-register expression)) + (= 2 (rtl:offset-number expression)))) + +(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-register expression)) + (= 3 (rtl:offset-number expression)))) (define-integrable (interpreter-free-pointer) (rtl:make-machine-register regnum:free-pointer)) @@ -220,10 +206,9 @@ MIT in each case. |# (define-integrable (interpreter-stack-pointer? register) (= (rtl:register-number register) regnum:stack-pointer)) - -;;;; Exports from machines/lapgen -(define lap:make-label-statement) -(define lap:make-unconditional-branch) -(define lap:make-entry-point) +(define-integrable (interpreter-dynamic-link) + (rtl:make-machine-register regnum:dynamic-link)) +(define-integrable (interpreter-dynamic-link? register) + (= (rtl:register-number register) regnum:dynamic-link)) \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/make.scm b/v7/src/compiler/machines/vax/make.scm index f20b71df8..d993232d7 100644 --- a/v7/src/compiler/machines/vax/make.scm +++ b/v7/src/compiler/machines/vax/make.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/make.scm,v 4.3 1988/03/08 18:24:52 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/make.scm,v 4.4 1989/05/17 20:30:41 jinx Exp $ +$MC68020-Header: make.scm,v 4.42 89/04/26 05:12:06 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,195 +33,13 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Compiler Make File for DEC VAX +;;;; Compiler: System Construction (declare (usual-integrations)) - -(load "base/pkging.bin" system-global-environment) - -(in-package compiler-package - - (define compiler-system - (make-environment - (define :name "Liar (DEC VAX)") - (define :version 4) - (define :modification 0) - (define :files) - -; (parse-rcs-header -; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/make.scm,v 4.3 1988/03/08 18:24:52 bal Exp $" -; (lambda (filename version date time zone author state) -; (set! :version (car version)) -; (set! :modification (cadr version)))) - - (define :files-lists - (list - (cons system-global-environment - '("base/pbs.bin" ;bit-string read/write syntax - "etc/direct.bin" ;directory reader - "etc/butils.bin" ;system building utilities - )) - - (cons compiler-package - '("base/switch.bin" ;compiler option switches - "base/macros.bin" ;compiler syntax - "base/hashtb.com" ;hash tables - )) - - (cons decls-package - '("base/decls.com" ;declarations - )) - - (cons compiler-package - '("base/object.com" ;tagged object support - "base/enumer.com" ;enumerations - "base/queue.com" ;queue abstraction - "base/sets.com" ;set abstraction - "base/mvalue.com" ;multiple-value support - "base/scode.com" ;SCode abstraction - "base/pmlook.com" ;pattern matcher: lookup - "base/pmpars.com" ;pattern matcher: parser - - "machines/vax/machin.com" ;machine dependent stuff - "base/toplev.com" ;top level - "base/debug.com" ;debugging support - "base/utils.com" ;odds and ends - - "base/cfg1.com" ;control flow graph - "base/cfg2.com" - "base/cfg3.com" - "base/ctypes.com" ;CFG datatypes - - "base/rvalue.com" ;Right hand values - "base/lvalue.com" ;Left hand values - "base/blocks.com" ;rvalue: blocks - "base/proced.com" ;rvalue: procedures - "base/contin.com" ;rvalue: continuations - - "base/subprb.com" ;subproblem datatype - - "rtlbase/rgraph.com" ;program graph abstraction - "rtlbase/rtlty1.com" ;RTL: type definitions - "rtlbase/rtlty2.com" ;RTL: type definitions - "rtlbase/rtlexp.com" ;RTL: expression operations - "rtlbase/rtlcon.com" ;RTL: complex constructors - "rtlbase/rtlreg.com" ;RTL: registers - "rtlbase/rtlcfg.com" ;RTL: CFG types - "rtlbase/rtlobj.com" ;RTL: CFG objects - "rtlbase/regset.com" ;RTL: register sets - - "base/infutl.com" ;utilities for info generation, shared - "back/insseq.com" ;LAP instruction sequences - "machines/vax/dassm1.com" ;disassembler - )) - - (cons disassembler-package - '("machines/vax/dassm2.com" ;disassembler - "machines/vax/dassm3.com" - "machines/vax/instr1.dbin" ;disassembler instructions - "machines/vax/instr2.dbin" - "machines/vax/instr3.dbin" - )) - - (cons fg-generator-package - '("fggen/fggen.com" ;SCode->flow-graph converter - "fggen/declar.com" ;Declaration handling - )) - - (cons fg-optimizer-package - '("fgopt/simapp.com" ;simulate applications - "fgopt/outer.com" ;outer analysis - "fgopt/folcon.com" ;fold constants - "fgopt/operan.com" ;operator analysis - "fgopt/closan.com" ;closure analysis - "fgopt/blktyp.com" ;environment type assignment - "fgopt/contan.com" ;continuation analysis - "fgopt/simple.com" ;simplicity analysis - "fgopt/order.com" ;subproblem ordering - "fgopt/conect.com" ;connectivity analysis - "fgopt/desenv.com" ;environment design - "fgopt/offset.com" ;compute node offsets - )) - - (cons rtl-generator-package - '("rtlgen/rtlgen.com" ;RTL generator - "rtlgen/rgproc.com" ;procedure headers - "rtlgen/rgstmt.com" ;statements - "rtlgen/rgrval.com" ;rvalues - "rtlgen/rgcomb.com" ;combinations - "rtlgen/rgretn.com" ;returns - "rtlgen/fndblk.com" ;find blocks and variables - "rtlgen/opncod.com" ;open-coded primitives - "machines/vax/rgspcm.com" ;special close-coded primitives - "rtlbase/rtline.com" ;linearizer - )) - - (cons rtl-cse-package - '("rtlopt/rcse1.com" ;RTL common subexpression eliminator - "rtlopt/rcse2.com" - "rtlopt/rcseep.com" ;CSE expression predicates - "rtlopt/rcseht.com" ;CSE hash table - "rtlopt/rcserq.com" ;CSE register/quantity abstractions - "rtlopt/rcsesr.com" ;CSE stack references - )) - - (cons rtl-optimizer-package - '("rtlopt/rlife.com" ;RTL register lifetime analyzer - "rtlopt/rdeath.com" ;RTL code compression - "rtlopt/rdebug.com" ;RTL optimizer debugging output - "rtlopt/ralloc.com" ;RTL register allocation - )) - - (cons debugging-information-package - '("base/infnew.com" ;debugging information generation - )) - - (cons lap-syntax-package - '("back/lapgn1.com" ;LAP generator. - "back/lapgn2.com" - "back/lapgn3.com" - "back/regmap.com" ;Hardware register allocator. - "back/linear.com" ;LAP linearizer. - "machines/vax/lapgen.com" ;code generation rules. - "machines/vax/rules1.com" - "machines/vax/rules2.com" - "machines/vax/rules3.com" - "machines/vax/rules4.com" - "back/syntax.com" ;Generic syntax phase - "machines/vax/coerce.com" ;Coercions: integer -> bit string - "back/asmmac.com" ;Macros for hairy syntax - "machines/vax/insmac.com" ;Macros for hairy syntax - "machines/vax/insutl.com" ;Utilities for instructions - "machines/vax/instr1.com" ;VAX Instructions - "machines/vax/instr2.com" ; " " - "machines/vax/instr3.com" ; " " - )) - - (cons bit-package - '("machines/vax/assmd.com" ;Machine dependent - "back/symtab.com" ;Symbol tables - "back/bitutl.com" ;Assembly blocks - "back/bittop.com" ;Assembler top level - )) - - )) - - )) - - (load-system! compiler-system)) - -;; This does not use system-global-environment so that multiple -;; versions of the compiler can coexist in different environments. -;; This file must therefore be loaded into system-global-environment -;; when the names below must be exported everywhere. - -(let ((top-level-env (the-environment))) - (for-each (lambda (name) - (local-assignment top-level-env name - (lexical-reference compiler-package name))) - '(CF - COMPILE-BIN-FILE - COMPILE-PROCEDURE - COMPILER:RESET! - COMPILER:WRITE-LAP-FILE))) +(package/system-loader "comp" '() 'QUERY) +(for-each (lambda (name) + ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) + '((COMPILER MACROS) + (COMPILER DECLARATIONS))) +(add-system! (make-system "Liar (DEC VAX)" 4 42 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/rgspcm.scm b/v7/src/compiler/machines/vax/rgspcm.scm index 41629d4e1..6daf0b8b3 100644 --- a/v7/src/compiler/machines/vax/rgspcm.scm +++ b/v7/src/compiler/machines/vax/rgspcm.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rgspcm.scm,v 4.1 1988/02/23 19:43:56 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rgspcm.scm,v 4.2 1989/05/17 20:30:47 jinx Rel $ +$MC68020-Header: rgspcm.scm,v 4.1 87/12/30 07:05:38 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,7 +33,7 @@ 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. 68020 version. +;;;; RTL Generation: Special primitive combinations. VAX version. (declare (usual-integrations)) diff --git a/v7/src/compiler/machines/vax/rules1.scm b/v7/src/compiler/machines/vax/rules1.scm index bed11c6d7..4e1373e02 100644 --- a/v7/src/compiler/machines/vax/rules1.scm +++ b/v7/src/compiler/machines/vax/rules1.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules1.scm,v 4.4 1988/03/21 21:46:31 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules1.scm,v 4.5 1989/05/17 20:30:53 jinx Exp $ +$MC68020-Header: rules1.scm,v 4.22 89/04/27 20:06:32 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,84 +33,93 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; VAX LAP Generation Rules: Data Transfers -;;; Matches MC68020 version 4.2 +;;;; LAP Generation Rules: Data Transfers. DEC VAX version. +;;; Note: All fixnum code has been moved to rulfix.scm. (declare (usual-integrations)) ;;;; Transfers to Registers +(define-rule statement + (ASSIGN (REGISTER (? target)) (REGISTER (? source))) + (QUALIFIER (machine-register? target)) + (LAP (MOV L + ,(standard-register-reference source false) + ,(register-reference target)))) + (define-rule statement (ASSIGN (REGISTER 14) (OFFSET-ADDRESS (REGISTER (? source)) (? offset))) (QUALIFIER (pseudo-register? source)) (LAP (MOVA L ,(indirect-reference! source offset) (R 14)))) (define-rule statement - (ASSIGN (REGISTER 10) (REGISTER 14)) - (LAP (MOV L (R 14) (R 10)))) + (ASSIGN (REGISTER 14) (OFFSET-ADDRESS (REGISTER 14) (? n))) + (increment-rn 14 n)) (define-rule statement (ASSIGN (REGISTER 10) (OFFSET-ADDRESS (REGISTER 14) (? offset))) - (let ((offset1 (* 4 offset))) - (LAP (MOVA L (@RO ,(offset-type offset1) 14 ,offset1) (R 10))))) + (let ((real-offset (* 4 offset))) + (LAP (MOVA L (@RO ,(datum-size real-offset) 14 ,real-offset) (R 10))))) (define-rule statement (ASSIGN (REGISTER 10) (OFFSET-ADDRESS (REGISTER (? source)) (? offset))) (QUALIFIER (pseudo-register? source)) (LAP (MOVA L ,(indirect-reference! source offset) (R 10)))) - + (define-rule statement (ASSIGN (REGISTER 10) (OBJECT->ADDRESS (REGISTER (? source)))) (QUALIFIER (pseudo-register? source)) - (if (and (dead-register? source) - (register-has-alias? source 'GENERAL)) - (let ((source (register-reference (register-alias source 'GENERAL)))) - (LAP (BIC L ,mask-reference ,source (R 10)))) - (let ((temp (reference-temporary-register! 'GENERAL))) - (LAP (MOV L ,(coerce->any source) ,temp) - (BIC L ,mask-reference ,temp (R 10)))))) - -;;; 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. + (let ((source (preferred-register-reference source))) + (LAP (BIC L ,mask-reference ,source (R 10))))) (define-rule statement - (ASSIGN (REGISTER 14) (OFFSET-ADDRESS (REGISTER 14) (? n))) - (increment-rnl 14 n)) + (ASSIGN (REGISTER 10) (OBJECT->ADDRESS (POST-INCREMENT (REGISTER 14) 1))) + (LAP (BIC L ,mask-reference (@R+ 14) (R 10)))) + +;;; 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)) (OFFSET-ADDRESS (REGISTER 14) (? n))) - (QUALIFIER (pseudo-register? target)) - ;; An alias is used here as eager register caching. It wins often. - (let ((offset (* 4 n))) - (LAP - (MOVA L (@RO ,(offset-type offset) 14 ,offset) - ,(reference-assignment-alias! target 'GENERAL))))) + (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n))) + (QUALIFIER (and (pseudo-register? target) (machine-register? source))) + (let ((source (indirect-reference! source n))) + (LAP (MOVA L ,source ,(standard-target-reference target))))) (define-rule statement - (ASSIGN (REGISTER 14) (REGISTER (? source))) - (LAP (MOV L ,(coerce->any source) (R 14)))) + (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n))) + (QUALIFIER (and (pseudo-register? target) (pseudo-register? source))) + (reuse-pseudo-register-alias! source 'GENERAL + (lambda (reusable-alias) + (delete-dead-registers!) + (add-pseudo-register-alias! target reusable-alias) + (increment-rn reusable-alias n)) + (lambda () + ;; *** This could use an add instruction. *** + (let ((source (indirect-reference! source n))) + (LAP (MOVA L ,source ,(standard-target-reference target))))))) (define-rule statement (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) (QUALIFIER (pseudo-register? target)) - (LAP ,(load-constant source (coerce->any target)))) + (LAP ,(load-constant source (standard-target-reference target)))) (define-rule statement (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) (QUALIFIER (pseudo-register? target)) (LAP (MOV L (@PCR ,(free-reference-label name)) - ,(reference-assignment-alias! target 'GENERAL)))) + ,(standard-target-reference target)))) (define-rule statement (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) (QUALIFIER (pseudo-register? target)) (LAP (MOV L (@PCR ,(free-assignment-label name)) - ,(reference-assignment-alias! target 'GENERAL)))) + ,(standard-target-reference target)))) (define-rule statement (ASSIGN (REGISTER (? target)) (REGISTER (? source))) @@ -117,57 +127,113 @@ MIT in each case. |# (move-to-alias-register! source 'GENERAL target) (LAP)) +(define (object->address source reg-ref) + (if (eq? source reg-ref) + (LAP (BIC L ,mask-reference ,reg-ref)) + (LAP (BIC L ,mask-reference ,source ,reg-ref)))) + +(define-integrable (ct/object->address object target) + (LAP ,(load-immediate (object-datum object) target))) + +(define (object->datum source reg-ref) + (if (eq? source reg-ref) + (LAP (BIC L ,mask-reference ,reg-ref)) + (LAP (BIC L ,mask-reference ,source ,reg-ref)))) + +(define-integrable (ct/object->datum object target) + (LAP ,(load-immediate (object-datum object) target))) + +(define-integrable (object->type source reg-ref) + (LAP (ROTL (S 8) ,source ,reg-ref))) + +(define-integrable (ct/object->type object target) + (LAP ,(load-immediate (object-type object) target))) + (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) + (QUALIFIER (pseudo-register? target)) + (convert-object/constant->register target constant + object->datum + ct/object->datum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? constant)))) (QUALIFIER (pseudo-register? target)) - (with-register-copy-alias! source 'GENERAL target - (lambda (target) - (LAP (BIC L ,mask-reference ,target))) - (lambda (source target) - (LAP (BIC L ,mask-reference ,source ,target))))) + (convert-object/constant->register target constant + object->address + ct/object->address)) (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) (QUALIFIER (pseudo-register? target)) - (with-register-copy-alias! source 'GENERAL target - (lambda (target) - (LAP (ROTL (S 8) ,target ,target))) - (lambda (source target) - (LAP (ROTL (S 8) ,source ,target))))) + (convert-object/register->register target source object->type)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) + (QUALIFIER (pseudo-register? target)) + (convert-object/register->register target source object->datum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) + (QUALIFIER (pseudo-register? target)) + (convert-object/register->register target source object->address)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset)))) + (QUALIFIER (pseudo-register? target)) + (convert-object/offset->register target address offset object->datum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset)))) + (QUALIFIER (pseudo-register? target)) + (convert-object/offset->register target address offset object->address)) (define-rule statement (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) (QUALIFIER (pseudo-register? target)) (let ((source (indirect-reference! address offset))) - (delete-dead-registers!) - (LAP (MOV L - ,source - ,(register-reference - (allocate-alias-register! target 'GENERAL)))))) + (LAP (MOV L ,source ,(standard-target-reference target))))) (define-rule statement (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 14) 1)) (QUALIFIER (pseudo-register? target)) - (delete-dead-registers!) - (LAP (MOV L - (@R+ 14) - ,(register-reference - (allocate-alias-register! target 'GENERAL))))) + (LAP (MOV L (@R+ 14) ,(standard-target-reference target)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) + (QUALIFIER (and (pseudo-register? target) (machine-register? datum))) + (let ((target (standard-target-reference target))) + (LAP (BIS L (& ,(make-non-pointer-literal type 0)) + ,(register-reference datum) ,target)))) (define-rule statement (ASSIGN (REGISTER (? target)) (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) + (QUALIFIER (and (pseudo-register? target) (pseudo-register? datum))) + (with-register-copy-alias! datum 'GENERAL target + (lambda (target) + (LAP (BIS L (& ,(make-non-pointer-literal type 0)) ,target))) + (lambda (source target) + (LAP (BIS L (& ,(make-non-pointer-literal type 0)) ,source ,target))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (CONSTANT (? type)) (CONSTANT (? datum)))) + (QUALIFIER (pseudo-register? target)) + (LAP ,(load-non-pointer type datum (standard-target-reference target)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) (QUALIFIER (pseudo-register? target)) - (let ((target* (coerce->any target)) - (datum (coerce->any datum))) - (delete-dead-registers!) - (let ((can-bump? (bump-type target*))) - (if (not can-bump?) - (LAP (MOV L ,datum ,reg:temp) - (MOV B ,(immediate-type type) ,reg:temp-type) - (MOV L ,reg:temp ,target*)) - (LAP (MOV L ,datum ,target*) - (MOV B ,(immediate-type type) ,can-bump?)))))) + (let ((target (standard-target-reference target))) + (LAP (MOVA B + (@PCR ,(rtl-procedure/external-label (label->object label))) + ,target) + (BIC L (& ,(make-non-pointer-literal type 0)) ,target)))) ;;;; Transfers to Memory @@ -179,37 +245,48 @@ MIT in each case. |# (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (UNASSIGNED)) - (LAP ,(load-non-pointer (ucode-type unassigned) 0 + (LAP ,(load-non-pointer (ucode-type unassigned) + 0 (indirect-reference! a n)))) +;; 1,3,4,5 of the following may need to do a delete-dead-registers! + (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r))) - (LAP (MOV L - ,(coerce->any r) - ,(indirect-reference! a n)))) + (let ((target (indirect-reference! a n))) + (LAP (MOV L + ,(standard-register-reference r false) + ,target)))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (POST-INCREMENT (REGISTER 14) 1)) - (LAP (MOV L - (@R+ 14) - ,(indirect-reference! a n)))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) - (let ((target (indirect-reference! a n))) - (LAP (MOV L ,(coerce->any r) ,target) - (MOV B ,(immediate-type type) ,(bump-type target))))) + (LAP (MOV L (@R+ 14) ,(indirect-reference! a n)))) (define-rule statement - (ASSIGN (OFFSET (REGISTER (? r0)) (? n0)) - (OFFSET (REGISTER (? r1)) (? n1))) - (let ((source (indirect-reference! r1 n1))) - (LAP (MOV L - ,source - ,(indirect-reference! r0 n0))))) + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) + (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) + (let ((target (indirect-reference! address offset))) + (LAP (BIS L ,(make-immediate (make-non-pointer-literal type 0)) + ,(standard-register-reference datum false) + ,target)))) + +(define-rule statement + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) + (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) + (let ((temp (reference-temporary-register! 'GENERAL)) + (target (indirect-reference! address offset))) + (LAP (MOVA B (@PCR ,(rtl-procedure/external-label (label->object label))) + ,temp) + (BIS L ,(make-immediate (make-non-pointer-literal type 0)) + ,temp ,target)))) + +(define-rule statement + (ASSIGN (OFFSET (REGISTER (? a0)) (? n0)) + (OFFSET (REGISTER (? a1)) (? n1))) + (let ((source (indirect-reference! a1 n1))) + (LAP (MOV L ,source ,(indirect-reference! a0 n0))))) ;;;; Consing @@ -228,25 +305,16 @@ MIT in each case. |# (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (REGISTER (? r))) - (LAP (MOV L ,(coerce->any r) (@R+ 12)))) + (LAP (MOV L ,(standard-register-reference r false) (@R+ 12)))) (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (OFFSET (REGISTER (? r)) (? n))) (LAP (MOV L ,(indirect-reference! r n) (@R+ 12)))) (define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (ENTRY:PROCEDURE (? label))) - (LAP (MOVA B (@PCR ,(rtl-procedure/external-label (label->object label))) - (@R+ 12)) - (MOV B ,(immediate-type (ucode-type compiled-expression)) - (@RO B 12 -1)))) - -;; This pops the top of stack into the heap - -(define-rule statement + ;; This pops the top of stack into the heap (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (POST-INCREMENT (REGISTER 14) 1)) (LAP (MOV L (@R+ 14) (@R+ 12)))) - ;;;; Pushes @@ -260,13 +328,19 @@ MIT in each case. |# (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (REGISTER (? r))) - (LAP (PUSHL ,(coerce->any r)))) + (LAP (PUSHL ,(standard-register-reference r false)))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) - (LAP (PUSHL ,(coerce->any r)) - (MOV B ,(immediate-type type) (@RO B 14 3)))) + (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) + (LAP (PUSHL ,(standard-register-reference datum 'GENERAL)) + (MOV B (S ,type) (@RO B 14 3)))) + +(define-rule statement + (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) + (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) + (LAP (PUSHA B (@PCR ,(rtl-procedure/external-label (label->object label)))) + (MOV B (S ,type) (@RO B 14 3)))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (OFFSET (REGISTER (? r)) (? n))) @@ -275,5 +349,72 @@ MIT in each case. |# (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (ENTRY:CONTINUATION (? label))) (LAP (PUSHA B (@PCR ,label)) - (MOV B ,(immediate-type (ucode-type compiler-return-address)) - (@RO B 14 3)))) + (MOV B (S ,(ucode-type compiled-entry)) (@RO B 14 3)))) + +;;;; CHAR->ASCII/BYTE-OFFSET + +(define (load-char-into-register type source target) + (let ((target (standard-target-reference target))) + (if (not (zero? type)) + (LAP ,(load-non-pointer type 0 target) + (MOV B ,source ,target)) + (LAP (MOVZ B L ,source ,target))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset)))) + (QUALIFIER (pseudo-register? target)) + (load-char-into-register 0 + (indirect-char/ascii-reference! address offset) + target)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (REGISTER (? source)))) + (QUALIFIER (pseudo-register? target)) + (let ((source (machine-register-reference source 'GENERAL))) + (load-char-into-register 0 source target))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET (REGISTER (? address)) (? offset))) + (QUALIFIER (pseudo-register? target)) + (load-char-into-register 0 + (indirect-byte-reference! address offset) + target)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (CONSTANT (? type)) + (BYTE-OFFSET (REGISTER (? address)) (? offset)))) + (QUALIFIER (pseudo-register? target)) + (load-char-into-register type + (indirect-byte-reference! address offset) + target)) + +(define-rule statement + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (CHAR->ASCII (CONSTANT (? character)))) + (LAP (MOV B + ,(make-immediate (char->signed-8-bit-immediate character)) + ,(indirect-byte-reference! address offset)))) + +(define-rule statement + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (REGISTER (? source))) + (let ((source (coerce->any/byte-reference source))) + (let ((target (indirect-byte-reference! address offset))) + (LAP (MOV B ,source ,target))))) + +(define-rule statement + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (CHAR->ASCII (REGISTER (? source)))) + (let ((source (coerce->any/byte-reference source))) + (let ((target (indirect-byte-reference! address offset))) + (LAP (MOV B ,source ,target))))) + +(define-rule statement + (ASSIGN (BYTE-OFFSET (REGISTER (? target)) (? target-offset)) + (CHAR->ASCII (OFFSET (REGISTER (? source)) (? source-offset)))) + (let ((source (indirect-char/ascii-reference! source source-offset))) + (LAP (MOV B ,source ,(indirect-byte-reference! target target-offset))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/rules2.scm b/v7/src/compiler/machines/vax/rules2.scm index 59241b695..b3a1057d7 100644 --- a/v7/src/compiler/machines/vax/rules2.scm +++ b/v7/src/compiler/machines/vax/rules2.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules2.scm,v 4.2 1988/03/21 21:47:00 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules2.scm,v 4.3 1989/05/17 20:31:04 jinx Rel $ +$MC68020-Header: rules2.scm,v 4.7 88/12/13 17:45:25 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,159 +33,148 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; VAX LAP Generation Rules: Predicates -;;; Matches MC68020 version 4.2 +;;;; LAP Generation Rules: Predicates. DEC VAX version. +;;; Note: All fixnum code has been moved to rulfix.scm. (declare (usual-integrations)) -;;;; Predicates - (define-rule predicate (TRUE-TEST (REGISTER (? register))) - (set-standard-branches! 'NEQU) - (LAP ,(test-non-pointer (ucode-type false) 0 (coerce->any register)))) + (set-standard-branches! 'NEQ) + (LAP ,(test-non-pointer (ucode-type false) + 0 + (standard-register-reference register false)))) (define-rule predicate - (TRUE-TEST (OFFSET (REGISTER (? register)) (? offset))) + (TRUE-TEST (? memory)) + (QUALIFIER (predicate/memory-operand? memory)) (set-standard-branches! 'NEQ) - (LAP ,(test-non-pointer (ucode-type false) 0 - (indirect-reference! register offset)))) + (LAP ,(test-non-pointer (ucode-type false) + 0 + (predicate/memory-operand-reference memory)))) (define-rule predicate (TYPE-TEST (REGISTER (? register)) (? type)) (QUALIFIER (pseudo-register? register)) - (set-standard-branches! 'EQLU) - (LAP ,(test-byte type - (register-reference - (load-alias-register! register 'GENERAL))))) + (set-standard-branches! 'EQL) + (LAP ,(test-byte type (reference-alias-register! register 'GENERAL)))) (define-rule predicate (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type)) (QUALIFIER (pseudo-register? register)) - (set-standard-branches! 'EQLU) + (set-standard-branches! 'EQL) (with-temporary-register-copy! register 'GENERAL - (lambda (reference) - (LAP (ROTL (S 8) ,reference ,reference) - ,(test-byte type reference))) - (lambda (source reference) - (LAP (ROTL (S 8) ,source ,reference) - ,(test-byte type reference))))) + (lambda (temp) + (LAP (ROTL (S 8) ,temp ,temp) + ,(test-byte type temp))) + (lambda (source temp) + (LAP (ROTL (S 8) ,source ,temp) + ,(test-byte type temp))))) -(define-rule predicate - (TYPE-TEST (OBJECT->TYPE (OFFSET (REGISTER (? register)) (? offset))) - (? type)) - (set-standard-branches! 'EQLU) - (LAP ,(test-byte type (bump-type (indirect-reference! register offset))))) - -(define-rule predicate - (UNASSIGNED-TEST (REGISTER (? register))) - (set-standard-branches! 'EQLU) - (LAP ,(test-non-pointer (ucode-type unassigned) 0 - (coerce->any register)))) +;; This is the split of a 68020 rule which seems wrong for post-increment. (define-rule predicate - (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset))) - (set-standard-branches! 'EQLU) - (LAP ,(test-non-pointer (ucode-type unassigned) 0 - (indirect-reference! register offset)))) - -;; *** Is all this hair needed on the VAX? -;; The CMP instruction operates anywhere. *** -;; *** All CMP instructions may be "backwards" *** + (TYPE-TEST (OBJECT->TYPE (OFFSET (REGISTER (? r)) (? offset))) (? type)) + (set-standard-branches! 'EQL) + (LAP ,(test-byte type (indirect-byte-reference! r (+ 3 (* 4 offset)))))) -(define (eq-test/constant*register constant register) - (set-standard-branches! 'EQLU) - (if (non-pointer-object? constant) - (LAP ,(test-non-pointer (primitive-type constant) - (primitive-datum constant) - (coerce->any register))) - (LAP (CMP L (@PCR ,(constant->label constant)) - ,(coerce->machine-register register))))) - -(define (eq-test/constant*memory constant memory-reference) - (set-standard-branches! 'EQLU) - (if (non-pointer-object? constant) - (LAP ,(test-non-pointer (primitive-type constant) - (primitive-datum constant) - memory-reference)) - (LAP (CMP L (@PCR ,(constant->label constant)) - ,memory-reference)))) - -(define (eq-test/register*register register-1 register-2) - (set-standard-branches! 'EQLU) - (LAP (CMP L ,(coerce->any register-2) - ,(coerce->any register-1)))) - -(define (eq-test/register*memory register memory-reference) - (set-standard-branches! 'EQLU) - (LAP (CMP L ,memory-reference - ,(coerce->machine-register register)))) - -(define (eq-test/memory*memory register-1 offset-1 register-2 offset-2) - (set-standard-branches! 'EQLU) - (let ((temp (reference-temporary-register! false))) - (let ((finish - (lambda (register-1 offset-1 register-2 offset-2) - (LAP (MOV L ,(indirect-reference! register-1 offset-1) - ,temp) - (CMP L ,(indirect-reference! register-2 offset-2) - ,temp))))) - (if (or (and (not (register-has-alias? register-1 'GENERAL)) - (register-has-alias? register-2 'GENERAL)) - (and (not (register-has-alias? register-1 'GENERAL)) - (register-has-alias? register-2 'GENERAL))) - (finish register-2 offset-2 register-1 offset-1) - (finish register-1 offset-1 register-2 offset-2))))) - (define-rule predicate - (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant))) - (eq-test/constant*register constant register)) - + (TYPE-TEST (OBJECT->TYPE (POST-INCREMENT (REGISTER 14) 1)) (? type)) + (set-standard-branches! 'EQL) + (let ((temp (reference-temporary-register! 'GENERAL))) + (LAP (ROTL (S 8) (@R+ 14) ,temp) + ,(test-byte type temp)))) + (define-rule predicate - (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register))) - (eq-test/constant*register constant register)) + (UNASSIGNED-TEST (REGISTER (? register))) + (set-standard-branches! 'EQL) + (LAP ,(test-non-pointer (ucode-type unassigned) + 0 + (standard-register-reference register false)))) (define-rule predicate - (EQ-TEST (OFFSET (REGISTER (? register)) (? offset)) (CONSTANT (? constant))) - (eq-test/constant*memory constant (indirect-reference! register offset))) + (UNASSIGNED-TEST (? memory)) + (QUALIFIER (predicate/memory-operand? memory)) + (set-standard-branches! 'EQL) + (LAP ,(test-non-pointer (ucode-type unassigned) + 0 + (predicate/memory-operand-reference memory)))) (define-rule predicate - (EQ-TEST (CONSTANT (? constant)) (OFFSET (REGISTER (? register)) (? offset))) - (eq-test/constant*memory constant (indirect-reference! register offset))) + (OVERFLOW-TEST) + (set-standard-branches! 'VS) + (LAP)) (define-rule predicate - (EQ-TEST (CONSTANT (? constant)) (POST-INCREMENT (REGISTER 14) 1)) - (eq-test/constant*memory constant (INST-EA (@R+ 14)))) + (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2))) + (QUALIFIER (and (pseudo-register? register-1) + (pseudo-register? register-2))) + (compare/register*register register-1 register-2 'EQL)) (define-rule predicate - (EQ-TEST (POST-INCREMENT (REGISTER 14) 1) (CONSTANT (? constant))) - (eq-test/constant*memory constant (INST-EA (@R+ 14)))) + (EQ-TEST (REGISTER (? register)) (? memory)) + (QUALIFIER (and (predicate/memory-operand? memory) + (pseudo-register? register))) + (compare/register*memory register + (predicate/memory-operand-reference memory) + 'EQL)) (define-rule predicate - (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2))) - (eq-test/register*register register-1 register-2)) + (EQ-TEST (? memory) (REGISTER (? register))) + (QUALIFIER (and (predicate/memory-operand? memory) + (pseudo-register? register))) + (compare/register*memory register + (predicate/memory-operand-reference memory) + 'EQL)) (define-rule predicate - (EQ-TEST (OFFSET (REGISTER (? register-1)) (? offset-1)) - (REGISTER (? register-2))) - (eq-test/register*memory register-2 - (indirect-reference! register-1 offset-1))) + (EQ-TEST (? memory-1) (? memory-2)) + (QUALIFIER (and (predicate/memory-operand? memory-1) + (predicate/memory-operand? memory-2))) + (compare/memory*memory (predicate/memory-operand-reference memory-1) + (predicate/memory-operand-reference memory-2) + 'EQL)) + +(define (eq-test/constant*register constant register) + (if (non-pointer-object? constant) + (begin + (set-standard-branches! 'EQL) + (LAP ,(test-non-pointer (object-type constant) + (object-datum constant) + (standard-register-reference register false)))) + (compare/register*memory register + (INST-EA (@PCR ,(constant->label constant))) + 'EQL))) + +(define (eq-test/constant*memory constant memory) + (if (non-pointer-object? constant) + (begin + (set-standard-branches! 'EQL) + (LAP ,(test-non-pointer (object-type constant) + (object-datum constant) + memory))) + (compare/memory*memory memory + (INST-EA (@PCR ,(constant->label constant))) + 'EQL))) (define-rule predicate - (EQ-TEST (REGISTER (? register-1)) - (OFFSET (REGISTER (? register-2)) (? offset-2))) - (eq-test/register*memory register-1 - (indirect-reference! register-2 offset-2))) + (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register))) + (QUALIFIER (pseudo-register? register)) + (eq-test/constant*register constant register)) (define-rule predicate - (EQ-TEST (POST-INCREMENT (REGISTER 14) 1) (REGISTER (? register))) - (eq-test/register*memory register (INST-EA (@R+ 14)))) + (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant))) + (QUALIFIER (pseudo-register? register)) + (eq-test/constant*register constant register)) (define-rule predicate - (EQ-TEST (REGISTER (? register)) (POST-INCREMENT (REGISTER 14) 1)) - (eq-test/register*memory register (INST-EA (@R+ 14)))) + (EQ-TEST (CONSTANT (? constant)) (? memory)) + (QUALIFIER (predicate/memory-operand? memory)) + (eq-test/constant*memory constant + (predicate/memory-operand-reference memory))) (define-rule predicate - (EQ-TEST (OFFSET (REGISTER (? register-1)) (? offset-1)) - (OFFSET (REGISTER (? register-2)) (? offset-2))) - (eq-test/memory*memory register-1 offset-1 register-2 offset-2)) + (EQ-TEST (? memory) (CONSTANT (? constant))) + (QUALIFIER (predicate/memory-operand? memory)) + (eq-test/constant*memory constant + (predicate/memory-operand-reference memory))) \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/rules3.scm b/v7/src/compiler/machines/vax/rules3.scm index b280522c3..f36e5437c 100644 --- a/v7/src/compiler/machines/vax/rules3.scm +++ b/v7/src/compiler/machines/vax/rules3.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules3.scm,v 4.6 1988/03/25 20:36:03 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules3.scm,v 4.7 1989/05/17 20:31:11 jinx Rel $ +$MC68020-Header: rules3.scm,v 4.15 88/12/30 07:05:20 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,8 +33,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; VAX LAP Generation Rules: Invocations and Entries -;;; Matches MC68020 version 4.2 +;;;; LAP Generation Rules: Invocations and Entries. DEC VAX version. (declare (usual-integrations)) @@ -47,73 +47,97 @@ MIT in each case. |# (define-rule statement (INVOCATION:APPLY (? frame-size) (? continuation)) + continuation ; ignored (LAP ,@(clear-map!) - ,(load-rnw frame-size 0) + ,(load-rn frame-size 0) (JMP ,entry:compiler-apply))) (define-rule statement (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) + frame-size continuation ; ignored (LAP ,@(clear-map!) (BR (@PCR ,label)))) +(define-rule statement + (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation)) + frame-size continuation ; ignored + ;; It expects the procedure at the top of the stack + (LAP ,@(clear-map!) + (CLR B (@RO B 14 3)) + (RSB))) + (define-rule statement (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) + continuation ; ignored (LAP ,@(clear-map!) - ,(load-rnw number-pushed 0) - (BR (@PCR ,label)))) - + ,(load-rn number-pushed 0) + (MOVA B (@PCR ,label) (R 3)) + (JMP ,entry:compiler-lexpr-apply))) + +(define-rule statement + (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation)) + continuation ; ignored + ;; It expects the procedure at the top of the stack + (LAP ,@(clear-map!) + ,(load-rn number-pushed 0) + (BIC L ,mask-reference (@R+ 14) (R 3)) + (JMP ,entry:compiler-lexpr-apply))) + +(define-rule statement + (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) + continuation ; ignored + (LAP ,@(clear-map!) + ;; The following assumes that at label there is + ;; (JMP (L )) + ;; The other possibility would be + ;; (JMP (@@PCR ,(free-uuo-link-label name frame-size))) + ;; and to have at label, but it is longer and slower. + (BR (@PCR ,(free-uuo-link-label name frame-size))))) + (define-rule statement (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension)) - (let ((set-extension (expression->machine-register! extension r9))) + continuation ; ignored + (let ((set-extension (expression->machine-register! extension r6))) (delete-dead-registers!) (LAP ,@set-extension ,@(clear-map!) - ,(load-rnw frame-size 0) - ;; MOVAB for consistency with JMP instruction. - (MOVA B (@PCR ,*block-start-label*) (R 8)) + ,(load-rn frame-size 0) + (MOVA B (@PCR ,*block-start-label*) (R 4)) (JMP ,entry:compiler-cache-reference-apply)))) (define-rule statement (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name)) - (let ((set-environment (expression->machine-register! environment r8))) + continuation ; ignored + (let ((set-environment (expression->machine-register! environment r7))) (delete-dead-registers!) (LAP ,@set-environment ,@(clear-map!) - ,(load-constant name (INST-EA (R 9))) - ,(load-rnw frame-size 0) + ,(load-constant name (INST-EA (R 8))) + ,(load-rn frame-size 0) (JMP ,entry:compiler-lookup-apply)))) - -(define-rule statement - (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) - (LAP ,@(clear-map!) - ,(load-rnw frame-size 0) - (MOV L (@PCR ,(free-uuo-link-label name)) (R 1)) - (PUSHL (R 1)) - (BIC L (R 11) (R 1)) - (BIC L (R 11) (@R 1) (R 1)) - (JMP (@R 1)))) - + (define-rule statement (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) + continuation ; ignored (LAP ,@(clear-map!) ,@(if (eq? primitive compiled-error-procedure) - (LAP ,(load-rnw frame-size 0) + (LAP ,(load-rn frame-size 0) (JMP ,entry:compiler-error)) (let ((arity (primitive-procedure-arity primitive))) (cond ((not (negative? arity)) - (LAP (MOV L (@PCR ,(constant->label primitive)) (R 8)) + (LAP (MOV L (@PCR ,(constant->label primitive)) (R 9)) (JMP ,entry:compiler-primitive-apply))) ((= arity -1) - (LAP (MOV L (& ,(-1+ frame-size)) + (LAP (MOV L ,(make-immediate (-1+ frame-size)) ,reg:lexpr-primitive-arity) - (MOV L (@PCR ,(constant->label primitive)) (R 8)) + (MOV L (@PCR ,(constant->label primitive)) (R 9)) (JMP ,entry:compiler-primitive-lexpr-apply))) (else ;; Unknown primitive arity. Go through apply. - (LAP ,(load-rnw frame-size 0) + (LAP ,(load-rn frame-size 0) (PUSHL (@PCR ,(constant->label primitive))) (JMP ,entry:compiler-apply)))))))) - + (let-syntax ((define-special-primitive-invocation (macro (name) @@ -122,6 +146,7 @@ MIT in each case. |# (? frame-size) (? continuation) ,(make-primitive-procedure name true)) + frame-size continuation ; ignored ,(list 'LAP (list 'UNQUOTE-SPLICING '(clear-map!)) (list 'JMP @@ -143,9 +168,13 @@ MIT in each case. |# ;;;; Invocation Prefixes (define-rule statement - (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 15)) + (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 14)) (LAP)) +(define-rule statement + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 10)) + (generate/move-frame-up frame-size (offset-reference 10 0))) + (define-rule statement (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (OFFSET-ADDRESS (REGISTER 14) (? offset))) @@ -153,10 +182,10 @@ MIT in each case. |# (cond ((zero? how-far) (LAP)) ((zero? frame-size) - (increment-rnl 14 how-far)) + (increment-rn 14 how-far)) ((= frame-size 1) (LAP (MOV L (@R+ 14) ,(offset-reference r14 (-1+ how-far))) - ,@(increment-rnl 14 (-1+ how-far)))) + ,@(increment-rn 14 (-1+ how-far)))) ((= frame-size 2) (if (= how-far 1) (LAP (MOV L (@RO B 14 4) (@RO B 14 8)) @@ -166,9 +195,10 @@ MIT in each case. |# ,(offset-reference r14 (-1+ how-far))))))) (LAP ,(i) ,(i) - ,@(increment-rnl 14 (- how-far 2)))))) + ,@(increment-rn 14 (- how-far 2)))))) (else - (generate/move-frame-up frame-size (offset-reference r14 offset)))))) + (generate/move-frame-up frame-size + (offset-reference r14 offset)))))) (define-rule statement (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) @@ -191,11 +221,47 @@ MIT in each case. |# (let ((temp-ref (register-reference temp))) (LAP (MOVA L ,(indirect-reference! base offset) ,temp-ref) (CMP L ,temp-ref (R 10)) - (B B LSSU (@PCR ,label)) + (B B LEQU (@PCR ,label)) (MOV L (R 10) ,temp-ref) (LABEL ,label) ,@(generate/move-frame-up* frame-size temp))))) +(define-rule statement + (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) + (OBJECT->ADDRESS (REGISTER (? source))) + (REGISTER 10)) + (QUALIFIER (pseudo-register? source)) + (let ((do-it + (lambda (reg-ref) + (let ((label (generate-label))) + (LAP (CMP L ,reg-ref (R 10)) + (B B LEQU (@PCR ,label)) + (MOV L (R 10) ,reg-ref) + (LABEL ,label) + ,@(generate/move-frame-up* frame-size + (lap:ea-R-register reg-ref))))))) + (with-temporary-register-copy! source 'GENERAL + (lambda (temp) + (LAP (BIC L ,mask-reference ,temp) + ,@(do-it temp))) + (lambda (source temp) + (LAP (BIC L ,mask-reference ,source ,temp) + ,@(do-it temp)))))) + +(define-rule statement + (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) + (REGISTER (? source)) + (REGISTER 10)) + (QUALIFIER (pseudo-register? source)) + (let ((reg-ref (move-to-temporary-register! source 'GENERAL)) + (label (generate-label))) + (LAP (CMP L ,reg-ref (R 10)) + (B B LEQU (@PCR ,label)) + (MOV L (R 10) ,reg-ref) + (LABEL ,label) + ,@(generate/move-frame-up* frame-size + (lap:ea-R-register reg-ref))))) + (define (generate/move-frame-up frame-size destination) (let ((temp (allocate-temporary-register! 'GENERAL))) (LAP (MOVA L ,destination ,(register-reference temp)) @@ -214,60 +280,51 @@ MIT in each case. |# (generator (allocate-temporary-register! 'GENERAL)))) (MOV L ,(register-reference destination) (R 14))))) -;;; This is invoked by the top level of the LAP GENERATOR. +;;;; External Labels -(define generate/quotation-header - (let ((declare-constants - (lambda (constants code) - (define (inner constants) - (if (null? constants) - code - (let ((entry (car constants))) - (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry)) - ,@(inner (cdr constants)))))) - (inner constants))) - (declare-references - (lambda (references entry:single entry:multiple) - (if (null? references) - (LAP) - (LAP (MOVA L (@PCR ,(cdar references)) (R 9)) - ,@(if (null? (cdr references)) - (LAP (JSB ,entry:single)) - (LAP ,(load-rnw (length references) 7) - (JSB ,entry:multiple))) - ,@(make-external-label (generate-label))))))) - (lambda (block-label constants references assignments uuo-links) - (declare-constants uuo-links - (declare-constants references - (declare-constants assignments - (declare-constants constants - (let ((debugging-information-label (allocate-constant-label)) - (environment-label (allocate-constant-label))) - (LAP - ;; Place holder for the debugging info filename - (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO) - (SCHEME-OBJECT ,environment-label ENVIRONMENT) - (MOVA L (@PCR ,environment-label) (R 8)) - ,@(if (and (null? references) - (null? assignments) - (null? uuo-links)) - (LAP ,(load-constant 0 '(@R 8))) - (LAP (MOV L ,reg:environment (@R 8)) - (MOVA L (@PCR ,block-label) (R 8)) - ,@(declare-references - references - entry:compiler-cache-variable - entry:compiler-cache-variable-multiple) - ,@(declare-references - assignments - entry:compiler-cache-assignment - entry:compiler-cache-assignment-multiple) - ,@(declare-references - uuo-links - entry:compiler-uuo-link - entry:compiler-uuo-link-multiple)))))))))))) +(define (make-external-label code label) + (set! compiler:external-labels + (cons label compiler:external-labels)) + (LAP (WORD U ,code) + (BLOCK-OFFSET ,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/Continuation Entries +;;;; 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 @@ -277,80 +334,181 @@ MIT in each case. |# ;;; 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-rule statement - (PROCEDURE-HEAP-CHECK (? label)) +(define-integrable (simple-procedure-header code-word label + entry:compiler-interrupt) (let ((gc-label (generate-label))) - (LAP ,@(procedure-header (label->object label) gc-label) - (CMP L ,reg:compiled-memtop (R 12)) - ;; *** LEQU ? *** - (B B LEQ (@PCR ,gc-label))))) + (LAP (LABEL ,gc-label) + (JSB ,entry:compiler-interrupt) + ,@(make-external-label code-word label) + (CMP L (R 12) ,reg:compiled-memtop) + (B B GEQ (@PCR ,gc-label))))) -;;; Note: do not change the (& ,mumble) in the setup-lexpr call to a -;;; (S ,mumble). The setup-lexpr code assumes a fixed calling -;;; sequence to compute the GC address if that is needed. This could -;;; be changed so that the microcode determined how far to back up -;;; based on the argument, or by examining the calling sequence. +(define-rule statement + (CONTINUATION-ENTRY (? internal-label)) + (make-external-label (continuation-code-word internal-label) + internal-label)) (define-rule statement - (SETUP-LEXPR (? label)) - (let ((procedure (label->object label))) - (LAP ,@(procedure-header procedure false) - (MOV W - (& ,(+ (rtl-procedure/n-required procedure) - (rtl-procedure/n-optional procedure) - (if (rtl-procedure/closure? procedure) 1 0))) - (R 1)) - (MOV L (S ,(if (rtl-procedure/rest? procedure) 1 0)) (R 2)) - (JSB ,entry:compiler-setup-lexpr)))) + (CONTINUATION-HEADER (? internal-label)) + (simple-procedure-header (continuation-code-word internal-label) + internal-label + entry:compiler-interrupt-continuation)) (define-rule statement - (CONTINUATION-HEAP-CHECK (? internal-label)) - (let ((gc-label (generate-label))) - (LAP (LABEL ,gc-label) - (JSB ,entry:compiler-interrupt-continuation) - ,@(make-external-label internal-label) - (CMP L ,reg:compiled-memtop (R 12)) - ;; *** LEQU ? *** - (B B LEQ (@PCR ,gc-label))))) + (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 + entry:compiler-interrupt-ic-procedure))))) (define-rule statement - (CONTINUATION-ENTRY (? internal-label)) - (LAP ,@(make-external-label internal-label))) + (OPEN-PROCEDURE-HEADER (? internal-label)) + (LAP (EQUATE ,(rtl-procedure/external-label + (label->object internal-label)) + ,internal-label) + ,@(simple-procedure-header internal-entry-code-word + internal-label + entry:compiler-interrupt-procedure))) + +(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 + entry:compiler-interrupt-procedure))) -(define (procedure-header procedure gc-label) - (let ((internal-label (rtl-procedure/label procedure)) - (external-label (rtl-procedure/external-label procedure))) - (LAP ,@(case (rtl-procedure/type procedure) - ((IC) - (LAP (ENTRY-POINT ,external-label) - (EQUATE ,external-label ,internal-label))) - ((CLOSURE) - (let ((required (1+ (rtl-procedure/n-required procedure))) - (optional (rtl-procedure/n-optional procedure))) - (LAP (ENTRY-POINT ,external-label) - ,@(make-external-label external-label) - ,(test-rnw required 0) - ,@(cond ((rtl-procedure/rest? procedure) - (LAP (B B GEQ (@PCR ,internal-label)))) - ((zero? optional) - (LAP (B B EQL (@PCR ,internal-label)))) - (else - (let ((wna-label (generate-label))) - (LAP (B B LSS (@PCR ,wna-label)) - ,(test-rnw (+ required optional) 0) - (B B LEQ (@PCR ,internal-label)) - (LABEL ,wna-label))))) - (JMP ,entry:compiler-wrong-number-of-arguments)))) - (else (LAP))) - ,@(if gc-label - (LAP (LABEL ,gc-label) - (JSB ,entry:compiler-interrupt-procedure)) - (LAP)) - ,@(make-external-label internal-label)))) - -(define (make-external-label label) - (set! compiler:external-labels - (cons label compiler:external-labels)) - (LAP (BLOCK-OFFSET ,label) - (LABEL ,label))) +;;;; Closures. These two statements are intertwined: + +(define magic-closure-constant + (- (* (ucode-type compiled-entry) #x1000000) 6)) + +(define-rule statement + (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) + (JMP ,entry:compiler-interrupt-closure) + ,@(make-external-label internal-entry-code-word external-label) + (ADD L (& ,magic-closure-constant) (@R 14)) + (LABEL ,internal-label) + (CMP L (R 12) ,reg:compiled-memtop) + (B B GEQ (@PCR ,gc-label)))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (CONSTANT (? type)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? size)))) + (QUALIFIER (pseudo-register? target)) + (generate/cons-closure (reference-target-alias! target 'GENERAL) + type procedure-label min max size)) + +(define-rule statement + (ASSIGN (? target) + (CONS-POINTER (CONSTANT (? type)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? size)))) + (QUALIFIER (standard-target-expression? target)) + (generate/cons-closure + (standard-target-expression->ea target) + type procedure-label min max size)) + +(define (generate/cons-closure target type procedure-label min max size) + (LAP ,(load-non-pointer (ucode-type manifest-closure) + (+ 3 size) + (INST-EA (@R+ 12))) + (MOV L (&U ,(+ #x100000 (make-procedure-code-word min max))) + (@R+ 12)) + (BIS L (& ,(make-non-pointer-literal type 0)) (R 12) ,target) + (MOV W (&U #x9f16) (@R+ 12)) ; (JSB (@& )) + (MOVA B (@PCR ,(rtl-procedure/external-label + (label->object procedure-label))) + (@R+ 12)) + (CLR W (@R+ 12)) + ,@(increment-rn 12 size))) + +;;;; Entry Header +;;; This is invoked by the top level of the LAP GENERATOR. + +(define generate/quotation-header + (let ((uuo-link-tag 0) + (reference-tag 1) + (assignment-tag 2)) + + (define (make-constant-block-tag tag datum) + (if (> datum #xffff) + (error "make-constant-block-tag: datum too large" datum) + (+ (* tag #x10000) datum))) + + (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 `((,(make-constant-block-tag tag (length constants)) + . ,label) + ,@constants)))) + (cons (car info) (inner constants)))) + + (define (transmogrifly uuos) + (define (inner name assoc) + (if (null? assoc) + (transmogrifly (cdr uuos)) + (cons (cons name (cdar assoc)) ; uuo-label + (cons (cons (caar assoc) ; frame-size + (allocate-constant-label)) + (inner name (cdr assoc)))))) + (if (null? uuos) + '() + (inner (caar uuos) (cdar uuos)))) + + (lambda (block-label constants references assignments uuo-links) + (let ((constant-info + (declare-constants uuo-link-tag (transmogrifly uuo-links) + (declare-constants reference-tag references + (declare-constants assignment-tag assignments + (declare-constants #f constants + (cons '() (LAP)))))))) + (let ((free-ref-label (car constant-info)) + (constants-code (cdr constant-info)) + (debugging-information-label (allocate-constant-label)) + (environment-label (allocate-constant-label))) + (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)) + ,@(if (null? free-ref-label) + (LAP) + (LAP (MOV L ,reg:environment (@PCR ,environment-label)) + (MOVA B (@PCR ,block-label) (R 3)) + (MOVA B (@PCR ,free-ref-label) (R 4)) + ,(load-rn (+ (if (null? uuo-links) 0 1) + (if (null? references) 0 1) + (if (null? assignments) 0 1)) + 0) + (JSB ,entry:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label)))))))))) + +;;; Local Variables: *** +;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** +;;; End: *** diff --git a/v7/src/compiler/machines/vax/rules4.scm b/v7/src/compiler/machines/vax/rules4.scm index 25e033df2..34c3ee097 100644 --- a/v7/src/compiler/machines/vax/rules4.scm +++ b/v7/src/compiler/machines/vax/rules4.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules4.scm,v 4.1 1988/01/05 22:25:13 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules4.scm,v 4.2 1989/05/17 20:31:24 jinx Rel $ +$MC68020-Header: rules4.scm,v 4.5 88/12/30 07:05:28 GMT cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,8 +33,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; VAX LAP Generation Rules: Interpreter Calls -;;; Matches MC68020 version 4.2 +;;;; LAP Generation Rules: Interpreter Calls. DEC VAX version. (declare (usual-integrations)) @@ -57,26 +57,12 @@ MIT in each case. |# (lookup-call entry:compiler-unbound? environment name)) (define (lookup-call entry environment name) - (let ((set-environment (expression->machine-register! environment r8))) + (let ((set-environment (expression->machine-register! environment r4))) (let ((clear-map (clear-map!))) (LAP ,@set-environment ,@clear-map - ,(load-constant name (INST-EA (R 9))) - (JSB ,entry) - ,@(make-external-label (generate-label)))))) - -(define-rule statement - (INTERPRETER-CALL:ENCLOSE (? number-pushed)) - (LAP (MOV L (R 12) ,reg:enclose-result) - (MOV B ,(immediate-type (ucode-type vector)) ,reg:enclose-result-type) - ,(load-non-pointer (ucode-type manifest-vector) number-pushed - (INST-EA (@R+ 12))) - - ,@(generate-n-times - number-pushed 5 - (lambda () (INST (MOV L (@R+ 14) (@R+ 12)))) - (lambda (generator) - (generator (allocate-temporary-register! 'GENERAL)))))) + ,(load-constant name (INST-EA (R 4))) + (JSB ,entry))))) (define-rule statement (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value)) @@ -89,19 +75,14 @@ MIT in each case. |# (assignment-call:default entry:compiler-set! environment name value)) (define (assignment-call:default entry environment name value) - (let ((set-environment (expression->machine-register! environment r7))) - (let ((set-value (expression->machine-register! value r9))) + (let ((set-environment (expression->machine-register! environment r3))) + (let ((set-value (expression->machine-register! value r5))) (let ((clear-map (clear-map!))) (LAP ,@set-environment ,@set-value ,@clear-map - ,(load-constant name (INST-EA (R 8))) - (JSB ,entry) - ,@(make-external-label (generate-label))))))) - -;; *** Is this used for procedures? If so it is wasteful in the VAX, -;; since there is no need to put the entry in a register first. -;; A MOVA instruction can be done directly to memory. *** + ,(load-constant name (INST-EA (R 4))) + (JSB ,entry)))))) (define-rule statement (INTERPRETER-CALL:DEFINE (? environment) (? name) @@ -118,62 +99,90 @@ MIT in each case. |# datum)) (define (assignment-call:cons-pointer entry environment name type datum) - (let ((set-environment (expression->machine-register! environment r7))) + (let ((set-environment (expression->machine-register! environment r3))) (let ((datum (coerce->any datum))) (let ((clear-map (clear-map!))) (LAP ,@set-environment - (MOV L ,datum ,reg:temp) - (MOV B ,(immediate-type type) ,reg:temp-type) ,@clear-map - (MOV L ,reg:temp (R 9)) - ,(load-constant name (INST-EA (R 8))) - (JSB ,entry) - ,@(make-external-label (generate-label))))))) + (BIS L (& ,(make-non-pointer-literal type 0)) ,datum (R 5)) + ,(load-constant name (INST-EA (R 4))) + (JSB ,entry)))))) + +(define-rule statement + (INTERPRETER-CALL:DEFINE (? environment) (? name) + (CONS-POINTER (CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (assignment-call:cons-procedure entry:compiler-define environment name type + label)) + +(define-rule statement + (INTERPRETER-CALL:SET! (? environment) (? name) + (CONS-POINTER (CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (assignment-call:cons-procedure entry:compiler-set! environment name type + label)) + +(define (assignment-call:cons-procedure entry environment name type label) + (let ((set-environment (expression->machine-register! environment r3))) + (LAP ,@set-environment + ,@(clear-map!) + (PUSHA B (@PCR ,(rtl-procedure/external-label (label->object label)))) + (MOV B ,(make-immediate type) (@RO B 14 3)) + (MOV L (@R+ 14) (R 5)) + ,(load-constant name (INST-EA (R 4))) + (JSB ,entry)))) (define-rule statement (INTERPRETER-CALL:CACHE-REFERENCE (? extension) (? safe?)) - (let ((set-extension (expression->machine-register! extension r9))) + (let ((set-extension (expression->machine-register! extension r3))) (let ((clear-map (clear-map!))) (LAP ,@set-extension ,@clear-map (JSB ,(if safe? entry:compiler-safe-reference-trap - entry:compiler-reference-trap)) - ,@(make-external-label (generate-label)))))) + entry:compiler-reference-trap)))))) (define-rule statement (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (? value)) (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (let ((set-extension (expression->machine-register! extension r8))) - (let ((set-value (expression->machine-register! value r9))) + (let ((set-extension (expression->machine-register! extension r3))) + (let ((set-value (expression->machine-register! value r4))) (let ((clear-map (clear-map!))) (LAP ,@set-extension ,@set-value ,@clear-map - (JSB ,entry:compiler-assignment-trap) - ,@(make-external-label (generate-label))))))) + (JSB ,entry:compiler-assignment-trap)))))) (define-rule statement (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) - (let ((set-extension (expression->machine-register! extension r8))) + (let ((set-extension (expression->machine-register! extension r3))) (let ((datum (coerce->any datum))) (let ((clear-map (clear-map!))) (LAP ,@set-extension - (MOV L ,datum ,reg:temp) - (MOV B ,(immediate-type type) ,reg:temp-type) ,@clear-map - (MOV L ,reg:temp (R 9)) - (JSB ,entry:compiler-assignment-trap) - ,@(make-external-label (generate-label))))))) + (BIS L (& ,(make-non-pointer-literal type 0)) ,datum (R 4)) + (JSB ,entry:compiler-assignment-trap)))))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-ASSIGNMENT + (? extension) + (CONS-POINTER (CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (let* ((set-extension (expression->machine-register! extension r3)) + (clear-map (clear-map!))) + (LAP ,@set-extension + ,@clear-map + (PUSHA B (@PCR ,(rtl-procedure/external-label (label->object label)))) + (MOV B ,(make-immediate type) (@RO B 14 3)) + (MOV L (@R+ 14) (R 4)) + (JSB ,entry:compiler-assignment-trap)))) (define-rule statement (INTERPRETER-CALL:CACHE-UNASSIGNED? (? extension)) - (let ((set-extension (expression->machine-register! extension r9))) + (let ((set-extension (expression->machine-register! extension r3))) (let ((clear-map (clear-map!))) (LAP ,@set-extension ,@clear-map - (JSB ,entry:compiler-unassigned?-trap) - ,@(make-external-label (generate-label)))))) - + (JSB ,entry:compiler-unassigned?-trap))))) \ No newline at end of file -- 2.25.1