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