#| -*-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
MIT in each case. |#
;;;; Assembler Machine Dependencies. DEC Vax version
-;;;
-;;; Matches version 4.2 of bobcat/assmd.scm
-;;;
(declare (usual-integrations))
\f
-(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))))
-\f
-;;; 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
#| -*-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
(error "Short label out of range" offset)))))
\f
;; *** 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)
#| -*-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
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))
\f
;;; 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)))))
+\f
;;; 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
(define (disassembler/instructions/address start-address end-address)
(disassembler/instructions false start-address end-address false))
-\f
+
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
(fluid-let ((*unparser-radix* 16))
(disassembler/for-each-instruction instruction-stream
(procedure offset instruction)
(loop (instruction-stream)))))))
\f
-(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)))
+\f
+(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)))))
+\f
+(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)
#| -*-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
;;;; VAX Disassembler: Top Level
(declare (usual-integrations))
-\f
+
(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)
+\f
+(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 @#<value>
+ (vector 'COMPILED
+ (read-procedure (+ offset 2))
+ arity))
+ ((#x9f16) ; JSB @#<value>
+ (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))))))))
+\f
(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
(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)))))
'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))
\f
;;;; Compiler specific information
+
(define-integrable (lookup-special-register reg table)
(assq reg table))
(12 . FREE-POINTER)
(13 . REGS-POINTER)
(14 . STACK-POINTER)
- (15 . PC)))
+ (15 . PROGRAM-COUNTER)))
\f
(define (make-offset deferred? register size offset)
(let ((key (if deferred? '@@RO '@RO)))
((REGISTER TEMPORARY ENTRY) effective-address)
(else false))))
\f
-(define interpreter-register-pointer
- 6)
-
(define interpreter-register-assignments
(let ()
(define (make-entries index names)
(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))))))))
\f
(define (make-pc-relative deferred? size pco)
`(,(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)
#| -*-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
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; VAX Disassembler
+;;;; VAX Disassembler: Internals
(declare (usual-integrations))
\f
-;;; 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))))
(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)
(define-integrable (extract+ bit-string start end)
(bit-string->signed-integer (bit-substring bit-string start end)))
\f
+;;;; 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)))))
+\f
;;;; 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))
(define-standard-instruction #xFD
(lambda ()
((vector-ref secondary-opcode-dispatch (get-immediate-byte)))))
+\f
+;; 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
(define-branch-instruction #x31 '(BR W) 16)
(define-branch-instruction #x10 '(BSB B) 8)
(define-branch-instruction #x30 '(BSB W) 16)
-\f
-;;;; 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)))))
-\f
-;;;; 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)
#| -*-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
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Compiler File Dependencies
+;;;; Compiler File Dependencies. VAX compiler.
(declare (usual-integrations))
\f
+(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))
+\f
(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))))
-\f
+
+(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
(source-node/close! node dependency))
(source-node/forward-closure node)))))
\f
-(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)
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)
(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)))))
\f
-(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))))
+\f
+(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)))
\f
;;;; 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)))
\f
;;;; 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"))
-\f
-(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"))
-\f
-(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")
-\f
-(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))
\f
;;;; 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
#| -*-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
\f
;;;; 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))
#| -*-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
;;;; 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))))
\f
;;;; Transformers and utilities
-(define early-transformers '())
-
(define (define-early-transformer name transformer)
(set! early-transformers
(cons (cons name transformer)
(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
(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
;; 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))))
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
(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
#| -*-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
\f
;;;; 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))
((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
#| -*-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
(()
(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)
#| -*-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
#| -*-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
;;
;; (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))
;; <fall through if out of range>
(define-instruction CASE
#| -*-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
\f
;;;; 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))
(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))
\f
;;;; Addressing modes
(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)
((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
(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)
#| -*-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
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))
\f
;;;; 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)))
(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
,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))))
\f
;; 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))))))))))
\f
+(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)))
(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!
(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))
\f
-(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)
(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))))))
(LAP ,(instruction-gen)
,@(loop (-1+ n)))))))
\f
+;;;; 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
+\f
+;;;; 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)))
+\f
(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))
(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)))
-\f
-;;;; Registers/Entries
+ ,@(make-external-label expression-code-word label)))
(let-syntax ((define-entries
(macro (start . names)
(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)))
\f
-(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!))
+\f
+;;;; 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))))
+\f
+;;;; 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
#| -*-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
;;;; Machine Model for DEC Vax
(declare (usual-integrations))
-\f(define-integrable (stack->memory-offset offset)
+\f;;; 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))))
-\f
-;;; 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
(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))
+\f
(define-integrable r0 0)
(define-integrable r1 1)
(define-integrable r2 2)
(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)
(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))
-\f
-(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)))
\f
+;; These must agree with cmpvax.m4
+
(define-integrable (interpreter-register:access)
(rtl:make-machine-register r0))
(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))
(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))
(define-integrable (interpreter-stack-pointer? register)
(= (rtl:register-number register) regnum:stack-pointer))
-\f
-;;;; 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
#| -*-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
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))
-\f
-(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
#| -*-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
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))
\f
#| -*-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
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))
\f
;;;; 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))))
+\f
+;;; 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)))
(move-to-alias-register! source 'GENERAL target)
(LAP))
\f
+(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))
+\f
+(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))))
\f
;;;; Transfers to Memory
(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)))))
\f
;;;; Consing
(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))))
-
\f
;;;; Pushes
(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)))
(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))))
+\f
+;;;; 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
#| -*-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
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))
\f
-;;;; 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))))
-\f
-;; *** 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)))))
-\f
(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))))
+\f
(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))
+\f
+(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
#| -*-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
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))
\f
(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))))
-\f
+ ,(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 <entry>))
+ ;; The other possibility would be
+ ;; (JMP (@@PCR ,(free-uuo-link-label name frame-size)))
+ ;; and to have <entry> 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))))
-
+\f
(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))))))))
-\f
+
(let-syntax
((define-special-primitive-invocation
(macro (name)
(? frame-size)
(? continuation)
,(make-primitive-procedure name true))
+ frame-size continuation ; ignored
,(list 'LAP
(list 'UNQUOTE-SPLICING '(clear-map!))
(list 'JMP
;;;; 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)))
(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))
,(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)
(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))
(generator (allocate-temporary-register! 'GENERAL))))
(MOV L ,(register-reference destination) (R 14)))))
\f
-;;; 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)))))
\f
-;;;; 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
;;; 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)))
\f
-(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 (@& <entry>))
+ (MOVA B (@PCR ,(rtl-procedure/external-label
+ (label->object procedure-label)))
+ (@R+ 12))
+ (CLR W (@R+ 12))
+ ,@(increment-rn 12 size)))
+\f
+;;;; 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))))))))))
+\f
+;;; Local Variables: ***
+;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
+;;; End: ***
#| -*-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
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))
\f
(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)))))
\f
(define-rule statement
(INTERPRETER-CALL:DEFINE (? environment) (? name) (? value))
(assignment-call:default entry:compiler-set! environment name value))
(define (assignment-call:default entry environment name value)
- (let ((set-environment (expression->machine-register! environment 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)
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))))
\f
(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
projects / mit-scheme.git / commitdiff