--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/assmd.scm,v 1.1 1995/01/10 20:52:28 adams Exp $
+$MC68020-Header: assmd.scm,v 1.36 89/08/28 18:33:33 GMT cph Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Assembler Machine Dependencies. Intel 386 version
+
+(declare (usual-integrations))
+\f
+(let-syntax ((ucode-type (macro (name) `',(microcode-type name))))
+
+(define-integrable maximum-padding-length
+ ;; Instructions can be any number of bytes long.
+ ;; Thus the maximum padding is 3 bytes.
+ 24)
+
+(define-integrable padding-string
+ ;; Pad with HLT instructions
+ (unsigned-integer->bit-string 8 #xf4))
+
+(define-integrable block-offset-width
+ ;; Block offsets are encoded words
+ 16)
+
+(define maximum-block-offset
+ (- (expt 2 (-1+ block-offset-width)) 1))
+
+(define-integrable (block-offset->bit-string offset start?)
+ (unsigned-integer->bit-string block-offset-width
+ (+ (* 2 offset)
+ (if start? 0 1))))
+
+
+(define-integrable nmv-type-string
+ (unsigned-integer->bit-string scheme-type-width
+ (ucode-type manifest-nm-vector)))
+
+(define (make-nmv-header n)
+ (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
+ nmv-type-string))
+
+;;; Machine dependent instruction order
+
+(define (instruction-insert! bits block position receiver)
+ (let ((l (bit-string-length bits)))
+ (bit-substring-move-right! bits 0 l block position)
+ (receiver (+ position l))))
+
+(define-integrable (instruction-initial-position block)
+ block ; ignored
+ 0)
+
+(define-integrable instruction-append bit-string-append)
+
+;;; end let-syntax
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/coerce.scm,v 1.1 1995/01/10 20:52:31 adams Exp $
+$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Intel i386 Specific Coercions
+
+(declare (usual-integrations))
+\f
+;; *** NOTE ***
+;; If you add coercions here, remember to also add them in "insmac.scm".
+
+(define make-coercion
+ (coercion-maker
+ `((UNSIGNED . ,coerce-unsigned-integer)
+ (SIGNED . ,coerce-signed-integer))))
+
+(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
+(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
+(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
+(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
+(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
+
+(define coerce-8-bit-signed (make-coercion 'SIGNED 8))
+(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
+(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: dassm1.scm,v 1.1 1995/01/10 20:52:32 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Disassembler: User Level
+;;; package: (compiler disassembler)
+
+(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))
+ (symbol-table?
+ (if (default-object? symbol-table?) true symbol-table?)))
+ (with-output-to-file (pathname-new-type pathname "lap")
+ (lambda ()
+ (let ((com-file (pathname-new-type pathname "com")))
+ (let ((object (fasload com-file)))
+ (if (compiled-code-address? object)
+ (let ((block (compiled-code-address->block object)))
+ (disassembler/write-compiled-code-block
+ block
+ (compiled-code-block/dbg-info block symbol-table?)))
+ (begin
+ (if (not
+ (and (scode/comment? object)
+ (dbg-info-vector? (scode/comment-text object))))
+ (error "Not a compiled file" com-file))
+ (let ((blocks
+ (vector->list
+ (dbg-info-vector/blocks-vector
+ (scode/comment-text object)))))
+ (if (not (null? blocks))
+ (do ((blocks blocks (cdr blocks)))
+ ((null? blocks) unspecific)
+ (disassembler/write-compiled-code-block
+ (car blocks)
+ (compiled-code-block/dbg-info (car blocks)
+ symbol-table?))
+ (if (not (null? (cdr blocks)))
+ (begin
+ (write-char #\page)
+ (newline))))))))))))))
+
+(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
+(define (disassembler/write-compiled-code-block block info)
+ (let ((symbol-table (and info (dbg-info/labels info))))
+ (write-string "Disassembly of ")
+ (write block)
+ (let loop ((info (compiled-code-block/debugging-info block)))
+ (cond ((string? info)
+ (write-string " (")
+ (write-string info)
+ (write-string ")"))
+ ((not (pair? info)))
+ ((vector? (car info))
+ (loop (cdr info)))
+ (else
+ (write-string " (Block ")
+ (write (cdr info))
+ (write-string " in ")
+ (write-string (car info))
+ (write-string ")"))))
+ (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)
+ (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)))
+
+ (define (write-caches offset size writer)
+ (let loop ((index (1+ (+ offset index)))
+ (how-many (quotient (- length offset) size)))
+ (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))))))
+
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-string "#[LINKAGE-SECTION ")
+ (write field)
+ (write-string "]")))
+ (case kind
+ ((0 3)
+ (write-caches
+ compiled-code-block/procedure-cache-offset
+ compiled-code-block/objects-per-procedure-cache
+ disassembler/write-procedure-cache))
+ ((1)
+ (write-caches
+ 0
+ compiled-code-block/objects-per-variable-cache
+ (lambda (block index)
+ (disassembler/write-variable-cache "Reference" block index))))
+ ((2)
+ (write-caches
+ 0
+ compiled-code-block/objects-per-variable-cache
+ (lambda (block index)
+ (disassembler/write-variable-cache "Assignment" block index))))
+ (else
+ (error "disassembler/write-linkage-section: Unknown section kind"
+ kind)))
+ (1+ (+ index length)))))
+\f
+(define-integrable (variable-cache-name cache)
+ ((ucode-primitive primitive-object-ref 2) cache 1))
+
+(define (disassembler/write-variable-cache kind block index)
+ (write-string kind)
+ (write-string " cache to ")
+ (write (variable-cache-name (disassembler/read-variable-cache block index))))
+
+(define (disassembler/write-procedure-cache block index)
+ (let ((result (disassembler/read-procedure-cache block index)))
+ (write (vector-ref result 2))
+ (write-string " argument procedure cache to ")
+ (case (vector-ref result 0)
+ ((COMPILED INTERPRETED)
+ (write (vector-ref result 1)))
+ ((VARIABLE)
+ (write-string "variable ")
+ (write (vector-ref result 1)))
+ (else
+ (error "disassembler/write-procedure-cache: Unknown cache kind"
+ (vector-ref result 0))))))
+
+(define (disassembler/write-instruction symbol-table offset write-instruction)
+ (if symbol-table
+ (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))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/dassm2.scm,v 1.1 1995/01/10 20:52:33 adams Exp $
+$MC68020-Header: /scheme/compiler/bobcat/RCS/dassm2.scm,v 4.18 1991/05/07 13:46:04 jinx Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Intel i386 Disassembler: Top Level
+;;; package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+(define (disassembler/read-variable-cache 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))))
+
+(define (disassembler/read-procedure-cache block index)
+ (fluid-let ((*block block))
+ (let* ((offset (compiled-code-block/index->offset index)))
+ (let ((opcode (read-unsigned-integer (+ offset 3) 8))
+ (arity (read-unsigned-integer offset 16)))
+ (case opcode
+ ((#xe9) ; (JMP (@PCR label))
+ ;; This should learn how to decode the new trampolines.
+ (vector 'COMPILED
+ (read-procedure (+ offset 4))
+ arity))
+ (else
+ (error "disassembler/read-procedure-cache: Unknown opcode"
+ opcode block index)))))))
+
+(define (disassembler/instructions 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)))))
+ '())))
+
+(define-integrable (disassembler/instructions/null? obj)
+ (null? obj))
+
+(define (disassembler/instructions/read 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 *valid?)
+
+(define (disassemble-one-instruction block offset symbol-table state receiver)
+ (fluid-let ((*block block)
+ (*current-offset offset)
+ (*symbol-table symbol-table)
+ (*valid? true))
+ (let ((start-offset *current-offset))
+ ;; External label markers come in two parts:
+ ;; An entry type descriptor, and a gc offset.
+ (cond ((eq? state 'EXTERNAL-LABEL-OFFSET)
+ (let* ((word (next-unsigned-16-bit-word))
+ (label (find-label *current-offset)))
+ (receiver *current-offset
+ (if label
+ `(BLOCK-OFFSET ,label)
+ `(WORD U ,word))
+ 'INSTRUCTION)))
+ ((external-label-marker? symbol-table offset state)
+ (let ((word (next-unsigned-16-bit-word)))
+ (receiver *current-offset
+ `(WORD U ,word)
+ 'EXTERNAL-LABEL-OFFSET)))
+ (else
+ (let ((instruction (disassemble-next-instruction)))
+ (if (or *valid? (not (eq? 'BYTE (car instruction))))
+ (receiver *current-offset
+ instruction
+ (disassembler/next-state instruction state))
+ (let ((inst `(BYTE U ,(caddr instruction))))
+ (receiver (1+ start-offset)
+ inst
+ (disassembler/next-state inst state))))))))))
+\f
+(define (disassembler/initial-state)
+ 'INSTRUCTION-NEXT)
+
+(define (disassembler/next-state instruction state)
+ state ; ignored
+ (if (and disassembler/compiled-code-heuristics?
+ (or (memq (car instruction) '(JMP RET))
+ (and (eq? (car instruction) 'CALL)
+ (let ((operand (cadr instruction)))
+ (or (and (pair? operand)
+ (eq? (car operand) 'ENTRY))
+ (let ((entry
+ (interpreter-register? operand)))
+ (and entry
+ (eq? (car entry) 'ENTRY))))))))
+ 'EXTERNAL-LABEL
+ 'INSTRUCTION))
+
+(define (disassembler/lookup-symbol 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)
+ (define-integrable (offset-word->offset word)
+ (fix:quotient (bit-string->unsigned-integer word) 2))
+
+ (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 (offset-word->offset contents))))
+ (and (positive? offset)
+ (loop offset)))
+ (= offset (offset-word->offset contents))))))))
+
+(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-signed-integer offset 32)
+ (+ (if *block
+ (object-datum *block)
+ 0)
+ (+ offset 4)))))))))
+
+(define (read-unsigned-integer offset size)
+ (bit-string->unsigned-integer (read-bits offset size)))
+
+(define (read-signed-integer offset size)
+ (bit-string->signed-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))
+\f
+(define-integrable (make-unsigned-reader nbits)
+ (let ((nbytes (fix:quotient nbits 8)))
+ (lambda ()
+ (let ((offset *current-offset))
+ (let ((word (read-bits offset nbits)))
+ (set! *current-offset (+ offset nbytes))
+ (bit-string->unsigned-integer word))))))
+
+(define-integrable (make-signed-reader nbits)
+ (let ((nbytes (fix:quotient nbits 8)))
+ (lambda ()
+ (let ((offset *current-offset))
+ (let ((word (read-bits offset nbits)))
+ (set! *current-offset (+ offset nbytes))
+ (bit-string->signed-integer word))))))
+
+(define next-byte (make-signed-reader 8))
+(define next-unsigned-byte (make-unsigned-reader 8))
+(define next-16-bit-word (make-signed-reader 16))
+(define next-unsigned-16-bit-word (make-unsigned-reader 16))
+(define next-32-bit-word (make-signed-reader 32))
+(define next-unsigned-32-bit-word (make-unsigned-reader 32))
+
+(define (find-label offset)
+ (and disassembler/symbolize-output?
+ (disassembler/lookup-symbol *symbol-table offset)))
+
+(define (interpreter-register? operand)
+ (define (regs-pointer? reg)
+ (if (symbol? reg)
+ (eq? reg 'ESI)
+ (= reg 6)))
+
+ (define (offset->register offset)
+ (let ((place (assq offset interpreter-register-offsets)))
+ (and place
+ (cdr place))))
+
+ (and (pair? operand)
+ (or (and (eq? (car operand) '@R)
+ (regs-pointer? (cadr operand))
+ (offset->register 0))
+ (and (eq? (car operand) '@RO)
+ (regs-pointer? (caddr operand))
+ (offset->register (cadddr operand))))))
+
+(define interpreter-register-offsets
+ (letrec ((make-entries
+ (lambda (kind offset names)
+ (if (null? names)
+ '()
+ (cons (cons offset `(,kind ,(car names)))
+ (make-entries kind
+ (+ offset 4)
+ (cdr names)))))))
+ (append
+ (make-entries
+ 'REGISTER 0
+ '(memtop
+ stack-guard
+ val
+ env
+ compiler-temp
+ expr
+ return-code
+ lexpr-actuals
+ primitive
+ closure-free
+ closure-space))
+\f
+ (make-entries
+ 'ENTRY #x40 ; 16 * 4
+ '(scheme-to-interface
+ scheme-to-interface/call
+ trampoline-to-interface
+ interrupt-procedure
+ interrupt-continuation
+ interrupt-closure
+ interrupt-dlink
+ primitive-apply
+ primitive-lexpr-apply
+ assignment-trap
+ reference-trap
+ safe-reference-trap
+ link
+ error
+ primitive-error
+ short-primitive-apply))
+
+ (make-entries
+ 'ENTRY #x-80
+ '(&+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
+ quotient
+ remainder
+ modulo
+ shortcircuit-apply ; Used by rules3, for speed.
+ shortcircuit-apply-size-1 ; Small frames, save time and space.
+ shortcircuit-apply-size-2
+ shortcircuit-apply-size-3
+ shortcircuit-apply-size-4
+ shortcircuit-apply-size-5
+ shortcircuit-apply-size-6
+ shortcircuit-apply-size-7
+ shortcircuit-apply-size-8)))))
+
+;; These are used by dassm1.scm
+
+(define compiled-code-block/procedure-cache-offset 1)
+(define compiled-code-block/objects-per-procedure-cache 2)
+(define compiled-code-block/objects-per-variable-cache 1)
+
+;; global variable used by runtime/udata.scm -- Moby yuck!
+
+(set! compiled-code-block/bytes-per-object 4)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/dassm3.scm,v 1.1 1995/01/10 20:52:34 adams Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Intel i386 Disassembler: Internals
+;;; package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+;; IMPORTANT: This disassembler currently does not handle
+;; operand size and address size modifiers.
+;; Thus it is "stuck" in 32-bit mode, just like the assembler.
+
+;; These really depend on the current operand size
+
+(define next-word next-32-bit-word)
+(define next-unsigned-word next-unsigned-32-bit-word)
+
+;; This really depends on the current address size
+
+(define next-offset next-word)
+
+
+(define-integrable (high-nibble byte)
+ (fix:lsh byte -4))
+
+(define-integrable (low-nibble byte)
+ (fix:and byte #xf))
+
+(define-integrable (low-three-bits byte)
+ (fix:and byte #x7))
+
+(define-integrable (modr/m-mod modr/m-byte)
+ (fix:and (fix:lsh modr/m-byte -6) #x3))
+
+(define-integrable (modr/m-reg modr/m-byte)
+ (fix:and (fix:lsh modr/m-byte -3) #x7))
+
+(define-integrable (modr/m-base modr/m-byte)
+ (fix:and modr/m-byte #x7))
+
+(define-integrable (sib-base sib-byte)
+ (fix:and sib-byte #x7))
+
+(define-integrable (sib-index sib-byte)
+ (fix:and (fix:lsh sib-byte -3) #x7))
+
+(define (sib-scale sib-byte)
+ (vector-ref '#(1 2 4 8) (fix:and (fix:lsh sib-byte -6) #x3)))
+
+(define (pc-relative prefix offset)
+ (cond ((find-label (+ *current-offset offset))
+ =>
+ (lambda (label)
+ `(,@prefix (@PCR ,label))))
+ (else
+ `(,@prefix (@PCO ,offset)))))
+
+(define (@R reg)
+ (let ((operand `(@R ,reg)))
+ (or (and disassembler/symbolize-output?
+ (interpreter-register? operand))
+ operand)))
+
+(define (@RO size reg offset)
+ (let ((operand `(@RO ,size ,reg ,offset)))
+ (or (and disassembler/symbolize-output?
+ (interpreter-register? operand))
+ operand)))
+\f
+(define (immediate-byte)
+ `(& ,(next-byte)))
+
+(define (immediate-word)
+ `(& ,(next-word)))
+
+(define (decode-r/m-32 byte)
+ (let ((base (modr/m-base byte)))
+ (define (ea size next-offset)
+ (cond ((fix:= base 4) ; esp
+ (let ((sib (next-unsigned-byte)))
+ (let ((base (sib-base sib))
+ (index (sib-index sib))
+ (scale (sib-scale sib)))
+ (if (fix:= index 4) ; esp
+ (cond ((and (fix:= base 5)
+ (fix:= scale 1))
+ (if (not size)
+ `(@ 0) ; ???
+ `(@ ,(next-offset))))
+ ((not size)
+ (@R base))
+ (else
+ (@RO size base (next-offset))))
+ (cond ((and (fix:= base 5)
+ (fix:= scale 1))
+ (if (not size)
+ (@R index)
+ (@RO size index (next-offset))))
+ ((not size)
+ `(@RI ,base ,index ,scale))
+ (else
+ `(@ROI ,size ,base ,(next-offset)
+ ,index ,scale)))))))
+ ((not size)
+ (@R base))
+ (else
+ (@RO size base (next-offset)))))
+
+ (case (modr/m-mod byte)
+ ((0)
+ (if (fix:= base 5) ; ebp
+ `(@ ,(next-32-bit-word))
+ (ea #f (lambda () 0))))
+ ((1)
+ (ea 'B next-byte))
+ ((2)
+ (ea 'W next-32-bit-word))
+ ((3)
+ `(R ,base))
+ (else
+ (error "decode-r/m: bad mode" byte)))))
+\f
+(define (decode-r/m-16 byte)
+ (let ((base (modr/m-base byte)))
+ (define (ea size offset)
+ (if (fix:< base 4)
+ (let ((base (if (fix:> base 1) 5 3))
+ (index (fix:+ 6 (fix:and base 1))))
+ (if size
+ `(@RI ,base ,index 1)
+ `(@ROI ,size ,base ,offset ,index 1)))
+ (let ((reg (vector-ref '#(6 7 5 3) (fix:- base 4))))
+ (if size
+ (@RO size reg offset)
+ (@R reg)))))
+
+ (case (modr/m-mod byte)
+ ((0)
+ (if (fix:= base 6)
+ `(@ ,(next-16-bit-word))
+ (ea #f 0)))
+
+ ((1)
+ (ea 'B (next-byte)))
+ ((2)
+ (ea 'W (next-16-bit-word)))
+ ((3)
+ `(R ,base))
+ (else
+ (error "decode-r/m: bad mode" byte)))))
+
+(define decode-r/m decode-r/m-32)
+
+(define (make-modr/m-decoder receiver)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (ea (decode-r/m modr/m-byte)))
+ (receiver (modr/m-reg modr/m-byte) ea))))
+
+(define (decode-E prefix reg-value)
+ (lambda (opcode-byte)
+ (let ((modr/m-byte (next-unsigned-byte)))
+ (if (not (= (modr/m-reg modr/m-byte) reg-value))
+ (unknown-inst opcode-byte modr/m-byte)
+ `(,@prefix ,(decode-r/m modr/m-byte))))))
+
+(define (decode-E/G prefix)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix ,ea (R ,reg)))))
+
+(define (decode-G/E prefix)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix (R ,reg) ,ea))))
+
+(define (decode-E/I prefix next)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ reg ; ignored, should be checked
+ `(,@prefix ,ea (& ,(next))))))
+
+(define (decode-G/E/I prefix next)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix (R ,reg) ,ea ,(next)))))
+\f
+(define (decode-E/G/I prefix next)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix ,ea (R ,reg) ,(next)))))
+
+(define (decode-G/M prefix)
+ ;; This should check that we are dealing with a memory EA!
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix (R ,reg) ,ea))))
+
+(define (decode-E/X prefix reg-kind)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix ,ea (,reg-kind ,reg)))))
+
+(define (decode-X/E prefix reg-kind)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix (,reg-kind ,reg) ,ea))))
+
+(define (decode-@ prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let ((offset (next-offset)))
+ `(,@prefix (@ ,offset)))))
+
+(define (decode-Ap prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let ((offset (next-offset)))
+ `(,@prefix (SEGMENT ,(next-unsigned-16-bit-word))
+ (OFFSET ,offset)))))
+
+(define (decode-Ib prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ `(,@prefix (& ,(next-byte)))))
+
+(define (decode-I16 prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ `(,@prefix (& ,(next-16-bit-word)))))
+
+(define (decode-Iw prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ `(,@prefix (& ,(next-word)))))
+
+(define (decode-ENTER opcode-byte)
+ opcode-byte ; ignored
+ (let ((first (next-unsigned-16-bit-word)))
+ `(ENTER (& ,first) (& ,(next-unsigned-byte)))))
+
+(define (decode-pcrb prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (pc-relative prefix (next-byte))))
+
+(define (decode-pcrw prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (pc-relative prefix (next-offset))))
+\f
+(define (unknown-inst opcode-byte . more-bytes)
+ (set! *valid? false) ; re-synch.
+ `(BYTE U ,opcode-byte ,@more-bytes))
+
+(define-integrable (simple-inst inst)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ inst))
+
+(define (backwards handler)
+ (lambda (opcode-byte)
+ (let ((result (handler opcode-byte)))
+ (let ((back (reverse result)))
+ (reverse (cons* (cadr back)
+ (cons (car back)
+ (cddr back))))))))
+
+(define-integrable (register-op prefix)
+ (lambda (opcode-byte)
+ `(,@prefix (R ,(fix:and opcode-byte #x7)))))
+
+(define jcc-opcodes
+ '#(
+ JO JNO JB JNB
+ JZ JNZ JBE JNBE
+ JS JNS JP JNP
+ JL JNL JLE JNLE))
+
+(define setcc-opcodes
+ '#(
+ SETO SETNO SETB SETNB
+ SETZ SETNZ SETBE SETNBE
+ SETS SETNS SETP SETNP
+ SETL SETNL SETLE SETNLE))
+
+(define (group-1&2 opcodes size get-operand)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let ((modr/m-byte (next-unsigned-byte)))
+ (let ((operand (decode-r/m modr/m-byte))
+ (opcode (vector-ref opcodes (modr/m-reg modr/m-byte))))
+ `(,opcode ,size ,operand ,(get-operand))))))
+
+(define (group-3 size read-operand)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (operand (decode-r/m modr/m-byte)))
+ (let ((dispatch (modr/m-reg modr/m-byte)))
+ (cond ((< dispatch 2)
+ `(TEST ,size ,operand (& ,(read-operand))))
+ ((< dispatch 4)
+ `(,(if (= dispatch 2) 'NOT 'NEG) ,size ,operand))
+ (else
+ `(,(vector-ref '#(MUL IMUL DIV IDIV) (- dispatch 4))
+ ,size
+ (R 0)
+ ,operand)))))))
+\f
+(define (group-4 size)
+ (lambda (opcode-byte)
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (operand (lambda () (decode-r/m modr/m-byte))))
+ (case (modr/m-reg modr/m-byte)
+ ((0)
+ `(INC ,size ,(operand)))
+ ((1)
+ `(DEC ,size ,(operand)))
+ (else
+ (unknown-inst opcode-byte modr/m-byte))))))
+
+(define (group-5 size)
+ (lambda (opcode-byte)
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (operand (lambda () (decode-r/m modr/m-byte))))
+ (case (modr/m-reg modr/m-byte)
+ ((0)
+ `(INC ,size ,(operand)))
+ ((1)
+ `(DEC ,size ,(operand)))
+ ((2)
+ `(CALL ,(operand)))
+ ((3)
+ `(CALL F ,(operand)))
+ ((4)
+ `(JMP ,(operand)))
+ ((5)
+ `(JMP F ,(operand)))
+ ((6)
+ `(PUSH ,(operand)))
+ (else
+ (unknown-inst opcode-byte modr/m-byte))))))
+
+(define (group-6&7 opcodes)
+ (lambda (second-byte)
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (op (vector-ref opcodes (modr/m-reg modr/m-byte))))
+ (if (not op)
+ (unknown-inst #x0f second-byte modr/m-byte)
+ `(,op ,(decode-r/m modr/m-byte))))))
+
+(define group-8
+ (let ((opcodes '#(#f #f #f #f BT BTS BTR BTC)))
+ (lambda (second-byte)
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (op (vector-ref opcodes (modr/m-reg modr/m-byte))))
+ (if (not op)
+ (unknown-inst #x0f second-byte modr/m-byte)
+ `(,op ,(decode-r/m modr/m-byte) (& ,(next-byte))))))))
+\f
+;;; Utilities for the main dispatchers
+
+(define (dispatch-on-bit low high)
+ (lambda (opcode-byte)
+ ((if (fix:= (fix:and opcode-byte #x8) 0) low high)
+ opcode-byte)))
+
+(define (dispatch-on-low-bits mask opcodes)
+ (lambda (opcode-byte)
+ ((vector-ref opcodes (fix:and opcode-byte mask))
+ opcode-byte)))
+
+(define (dispatch-on-low-nibble . cases)
+ (if (not (= (length cases) 16))
+ (error "dispatch-on-low-nibble: Wrong number of cases"
+ cases))
+ (dispatch-on-low-bits #xf (list->vector cases)))
+
+(define (dispatch-on-low-three-bits . cases)
+ (if (not (= (length cases) 8))
+ (error "dispatch-on-low-three-bits: Wrong number of cases"
+ cases))
+ (dispatch-on-low-bits #x7 (list->vector cases)))
+
+;;; Floating-point instructions
+
+(define (fp-table-maker fields->index)
+ (lambda (cases)
+ (let ((table (make-vector 64 #f)))
+ (for-each
+ (lambda (a-case)
+ (let ((opcode (car a-case))
+ (next (cadr a-case)))
+ (let ((index (fields->index opcode next)))
+ (cond ((not index)
+ (error "make-table-1-3: Bad fields" a-case))
+ ((vector-ref table index)
+ (error "make-table-1-3: Duplicate case"
+ (vector-ref table index) a-case)))
+ (vector-set! table index (cddr a-case)))))
+ cases)
+ table)))
+
+(define make-table-1-3
+ (fp-table-maker
+ (lambda (opcode next)
+ (and (fix:< opcode 8)
+ (fix:< next 8)
+ (fix:or (fix:lsh next 3) opcode)))))
+
+(define make-table-4&5
+ (fp-table-maker
+ (lambda (opcode next)
+ (and (or (fix:= opcode 1) (fix:= opcode 3))
+ (fix:< next #x20)
+ (fix:or (fix:lsh (fix:- opcode 1) 4)
+ next)))))
+\f
+(define decode-fp
+ (let-syntax ((IN (macro (body . bindings)
+ `(LET ,bindings
+ ,body))))
+ (IN
+ (lambda (opcode-byte)
+ (let* ((next (next-unsigned-byte))
+ (disc (fix:and opcode-byte #x7))
+ (index (fix:or (fix:and next #x38) disc)))
+
+ (cond ((not (fix:= (modr/m-mod next) 3)) ; register op
+ (let ((prefix (vector-ref table-1&2 index)))
+ (if (not prefix)
+ (maybe-special opcode-byte next)
+ `(,@prefix ,(decode-r/m next)))))
+ ((or (fix:= disc 3)
+ (and (fix:= disc 1)
+ (fix:= (fix:and next #x20) #x20)))
+ (let ((inst (vector-ref
+ table-4&5
+ (fix:or (fix:lsh (fix:- disc 1) 4)
+ (fix:and next #x1f)))))
+ (if (not inst)
+ (maybe-special opcode-byte next)
+ inst)))
+ (else
+ (let ((spec (vector-ref table-3 index))
+ (loc (fix:and next #x7)))
+ (cond ((not spec)
+ (maybe-special opcode-byte next))
+ ((null? (cdr spec))
+ `(,(car spec) (ST ,loc)))
+ ((cadr spec) ; reverse ops
+ `(,(car spec) (ST ,loc) (ST 0)))
+ (else
+ `(,(car spec) (ST 0) (ST ,loc)))))))))
+
+ (maybe-special
+ (let ((special '(
+ (#xe0df FNSTSW (R 0))
+ (#xd0d9 FNOP)
+ )))
+ (lambda (opcode-byte next)
+ (let* ((word (fix:or (fix:lsh next 8) opcode-byte))
+ (place (assq word special)))
+ (if place
+ (cdr place)
+ (unknown-inst opcode-byte next))))))
+
+\f
+ (table-4&5
+ (make-table-4&5
+ '(
+ (1 4 FTST)
+ (1 5 FXAM)
+ (1 #xe FLDZ)
+ (1 8 FLD1)
+ (1 #xb FLDPI)
+ (1 9 FLD2T)
+ (1 #xa FLD2E)
+ (1 #xc FLDG2)
+ (1 #xd FLDLN2)
+ (1 #x1a FSQRT)
+ (1 #x1d FSCALE)
+ (1 #x14 FXTRACT)
+ (1 #x18 FPREM)
+ (1 #x15 FPREM1)
+ (1 #x1c FRNDINT)
+ (1 1 FABS)
+ (1 0 FCHS)
+ (1 #x1f FCOS)
+ (1 #x12 FPTAN)
+ (1 #x13 FPATAN)
+ (1 #x1e FSIN)
+ (1 #x1b FSINCOS)
+ (1 #x10 F2XM1)
+ (1 #x11 FYL2X)
+ (1 #x19 FYL2XP1)
+ (3 3 FNINIT)
+ (3 2 FCLEX)
+ (1 #x17 FINCSTP)
+ (1 #x16 FDECSTP))))
+
+
+ (table-3
+ (make-table-1-3
+ '(
+ (1 0 FLD)
+ (5 2 FST)
+ (5 3 FSTP) ; i486 book has 5 1
+ (1 1 FXCH #f)
+ (0 2 FCOM #f)
+ (0 3 FCOMP #f)
+ (6 3 FCOMPP #f) ; really only with (ST 1)
+ (5 4 FUCOM #f)
+ (5 5 FUCOMP #f)
+ (2 5 FUCOMPP #f) ; really only with (ST 1)
+ (0 0 FADD #f)
+ (4 0 FADD #t)
+ (0 5 FSUB #f)
+ (4 5 FSUB #t)
+ (6 5 FSUBP #t)
+ (0 4 FSUBR #f)
+ (4 4 FSUBR #t)
+ (6 4 FSUBRP #t)
+ (0 1 FMUL #f)
+ (4 1 FMUL #t)
+ (6 1 FMULP #t)
+ (0 7 FDIV #f)
+ (4 7 FDIV #t)
+ (6 7 FDIVP #t)
+ (0 6 FDIVR #f)
+ (4 6 FDIVR #t)
+ (6 6 FDIVRP #t)
+ (5 0 FFREE))))
+\f
+ (table-1&2
+ (make-table-1-3
+ '(
+ (1 0 FLD S)
+ (5 0 FLD D)
+ (3 5 FLD X)
+ (7 0 FILD H)
+ (3 0 FILD L)
+ (7 5 FILD Q)
+ (7 4 FBLD)
+ (1 2 FST S)
+ (5 2 FST D)
+ (1 3 FSTP S) ; i486 book has 3 3 like FISTP
+ (5 3 FSTP D)
+ (3 7 FSTP X)
+ (7 2 FIST H)
+ (3 2 FIST L)
+ (7 3 FISTP H)
+ (3 3 FISTP L)
+ (7 7 FISTP Q)
+ (7 6 FBSTP)
+ (0 2 FCOM S (ST 0))
+ (4 2 FCOM D (ST 0))
+ (0 3 FCOMP S (ST 0))
+ (4 3 FCOMP D (ST 0))
+ (6 2 FICOM H)
+ (2 2 FICOM L)
+ (6 3 FICOMP H)
+ (2 3 FICOMP L)
+ (0 0 FADD S)
+ (4 0 FADD D)
+ (0 4 FSUB S)
+ (4 4 FSUB D)
+ (0 5 FSUBR S)
+ (4 5 FSUBR D)
+ (0 1 FMUL S)
+ (4 1 FMUL D)
+ (0 6 FDIV S)
+ (4 6 FDIV D) ; i486 manual has 4 4 like FSUB
+ (0 7 FDIVR S)
+ (4 7 FDIVR D)
+ (6 0 FIADD H)
+ (2 0 FIADD L)
+ (6 4 FISUB H)
+ (2 4 FISUB L)
+ (6 5 FISUBR H)
+ (2 5 FISUBR L)
+ (6 1 FIMUL H)
+ (2 1 FIMUL L)
+ (6 6 FIDIV H)
+ (2 6 FIDIV L)
+ (6 7 FIDIVR H)
+ (2 7 FIDIVR L)
+ (5 7 FNSTSW)
+ (1 5 FLDCW)
+ (1 7 FNSTCW)
+ (1 6 FNSTENV)
+ (1 4 FLDENV)
+ (5 6 FNSAVE)
+ (5 4 FRSTOR)))))))
+\f
+(define dispatch/0f
+ (let* ((unknown-inst
+ (lambda (second-byte)
+ (unknown-inst #x0f second-byte)))
+ (table
+ (vector
+ (dispatch-on-low-nibble ; 0
+ (group-6&7 '#(SLDT STR LLDT LTR VERR VERW #f #f))
+ (group-6&7 '#(SGDT SIDT LGDT LIDT SMSW #f LMSW #f))
+ (decode-G/E '(LAR))
+ (decode-G/E '(LSL))
+ unknown-inst
+ unknown-inst
+ (simple-inst '(CLTS))
+ unknown-inst
+
+ (simple-inst '(INVD))
+ (simple-inst '(WBINVD))
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst)
+
+ unknown-inst ; 1
+
+ (dispatch-on-bit ; 2
+ (dispatch-on-low-three-bits
+ (decode-X/E '(MOV) 'CR)
+ (decode-X/E '(MOV) 'DR)
+ (decode-E/X '(MOV) 'CR)
+ (decode-E/X '(MOV) 'DR)
+ (decode-X/E '(MOV) 'TR)
+ unknown-inst
+ (decode-E/X '(MOV) 'TR)
+ unknown-inst)
+ unknown-inst)
+
+ unknown-inst ; 3
+
+ unknown-inst ; 4
+
+ unknown-inst ; 5
+
+ unknown-inst ; 6
+
+ unknown-inst ; 7
+
+ (lambda (opcode-byte) ; 8
+ ((decode-pcrw
+ `(,(vector-ref jcc-opcodes (low-nibble opcode-byte))
+ W))
+ opcode-byte))
+
+ (lambda (opcode-byte) ; 9
+ ((decode-E
+ `(,(vector-ref setcc-opcodes (low-nibble opcode-byte))))
+ opcode-byte))
+\f
+ (dispatch-on-low-nibble ; A
+ (simple-inst '(PUSH FS))
+ (simple-inst '(POP FS))
+ unknown-inst
+ (decode-E/G '(BT))
+ (decode-E/G/I '(SHLD) immediate-byte)
+ (decode-E/G/I '(SHLD) (lambda () '(R 1)))
+ (decode-E/G '(CMPXCHG B))
+ (decode-E/G '(CMPXCHG W))
+
+ (simple-inst '(PUSH GS))
+ (simple-inst '(POP GS))
+ unknown-inst
+ (decode-E/G '(BTS))
+ (decode-E/G/I '(SHRD) immediate-byte)
+ (decode-E/G/I '(SHRD) (lambda () '(R 1)))
+ unknown-inst
+ (decode-G/E '(IMUL W)))
+
+ (dispatch-on-low-nibble ; B
+ unknown-inst
+ unknown-inst
+ (decode-G/M '(LSS))
+ (decode-E/G '(BTR))
+ (decode-G/M '(LFS))
+ (decode-G/M '(LGS))
+ (decode-G/E '(MOVZX B))
+ (decode-G/E '(MOVZX W))
+
+ unknown-inst
+ unknown-inst
+ group-8
+ (decode-E/G '(BTC))
+ (decode-G/E '(BSF))
+ (decode-G/E '(BSR))
+ (decode-G/E '(MOVSX B))
+ (decode-G/E '(MOVSX W)))
+
+ (dispatch-on-bit ; C
+ (dispatch-on-low-three-bits
+ (decode-E/G '(XADD B))
+ (decode-E/G '(XADD W))
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst)
+ (register-op '(BSWAP)))
+
+ unknown-inst ; D
+
+ unknown-inst ; E
+
+ unknown-inst))) ; F
+
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let ((next (next-unsigned-byte)))
+ ((vector-ref table (high-nibble next))
+ next)))))
+\f
+(define disassemble-next-instruction
+ (let* ((arith-opcodes
+ '#(ADD OR ADC SBB AND SUB XOR CMP))
+ (shift-opcodes
+ '#(ROL ROR RCL RCR SHL SHR SAL SAR))
+ (table
+ (vector
+ (dispatch-on-low-nibble ; 0
+ (decode-E/G '(ADD B))
+ (decode-E/G '(ADD W))
+ (decode-G/E '(ADD B))
+ (decode-G/E '(ADD W))
+ (decode-Ib '(ADD B (R 0)))
+ (decode-Iw '(ADD W (R 0)))
+ (simple-inst '(PUSH ES))
+ (simple-inst '(POP ES))
+
+ (decode-E/G '(OR B))
+ (decode-E/G '(OR W))
+ (decode-G/E '(OR B))
+ (decode-G/E '(OR W))
+ (decode-Ib '(OR B (R 0)))
+ (decode-Iw '(OR W (R 0)))
+ (simple-inst '(PUSH CS))
+ dispatch/0f)
+
+ (dispatch-on-low-nibble ; 1
+ (decode-E/G '(ADC B))
+ (decode-E/G '(ADC W))
+ (decode-G/E '(ADC B))
+ (decode-G/E '(ADC W))
+ (decode-Ib '(ADC B (R 0)))
+ (decode-Iw '(ADC W (R 0)))
+ (simple-inst '(PUSH SS))
+ (simple-inst '(POP SS))
+
+ (decode-E/G '(SBB B))
+ (decode-E/G '(SBB W))
+ (decode-G/E '(SBB B))
+ (decode-G/E '(SBB W))
+ (decode-Ib '(SBB B (R 0)))
+ (decode-Iw '(SBB W (R 0)))
+ (simple-inst '(PUSH DS))
+ (simple-inst '(POP DS)))
+
+ (dispatch-on-low-nibble ; 2
+ (decode-E/G '(AND B))
+ (decode-E/G '(AND W))
+ (decode-G/E '(AND B))
+ (decode-G/E '(AND W))
+ (decode-Ib '(AND B (R 0)))
+ (decode-Iw '(AND W (R 0)))
+ (simple-inst '(ESSEG))
+ (simple-inst '(DAA))
+
+ (decode-E/G '(SUB B))
+ (decode-E/G '(SUB W))
+ (decode-G/E '(SUB B))
+ (decode-G/E '(SUB W))
+ (decode-Ib '(SUB B (R 0)))
+ (decode-Iw '(AND W (R 0)))
+ (simple-inst '(CSSEG))
+ (simple-inst '(DAS)))
+\f
+ (dispatch-on-low-nibble ; 3
+ (decode-E/G '(XOR B))
+ (decode-E/G '(XOR W))
+ (decode-G/E '(XOR B))
+ (decode-G/E '(XOR W))
+ (decode-Ib '(XOR B (R 0)))
+ (decode-Iw '(XOR W (R 0)))
+ (simple-inst '(SSSEG))
+ (simple-inst '(AAA))
+
+ (decode-E/G '(CMP B))
+ (decode-E/G '(CMP W))
+ (decode-G/E '(CMP B))
+ (decode-G/E '(CMP W))
+ (decode-Ib '(CMP B (R 0)))
+ (decode-Iw '(CMP W (R 0)))
+ (simple-inst '(DSSEG))
+ (simple-inst '(AAS)))
+
+ (dispatch-on-bit ; 4
+ (register-op '(INC))
+ (register-op '(DEC)))
+
+ (dispatch-on-bit ; 5
+ (register-op '(PUSH))
+ (register-op '(POP)))
+
+ (dispatch-on-low-nibble ; 6
+ (simple-inst '(PUSHA))
+ (simple-inst '(POPA))
+ (decode-G/M '(BOUND))
+ (decode-E/G '(ARPL))
+ (simple-inst '(FSSEG))
+ (simple-inst '(GSSEG))
+ (simple-inst '(OPSIZE))
+ (simple-inst '(ADSIZE))
+
+ (decode-Iw '(PUSH W))
+ (decode-G/E/I '(IMUL W) immediate-word)
+ (decode-Ib '(PUSH B))
+ (decode-G/E/I '(IMUL B) immediate-byte)
+ (simple-inst '(INS B))
+ (simple-inst '(INS W))
+ (simple-inst '(OUTS B))
+ (simple-inst '(OUTS W)))
+
+ (lambda (opcode-byte) ; 7
+ ((decode-pcrb
+ `(,(vector-ref jcc-opcodes (low-nibble opcode-byte))
+ B))
+ opcode-byte))
+\f
+ (dispatch-on-low-nibble ; 8
+ (group-1&2 arith-opcodes 'B immediate-byte)
+ (group-1&2 arith-opcodes 'W immediate-word)
+ (decode-Ib '(MOV B (R 0)))
+ (group-1&2 arith-opcodes 'W immediate-byte)
+ (decode-E/G '(TEST B))
+ (decode-E/G '(TEST W))
+ (decode-E/G '(XCHG B))
+ (decode-E/G '(XCHG W))
+
+ (decode-E/G '(MOV B))
+ (decode-E/G '(MOV W))
+ (decode-G/E '(MOV B))
+ (decode-G/E '(MOV W))
+ (decode-E/X '(MOV) 'SR)
+ (decode-G/M '(LEA))
+ (decode-X/E '(MOV) 'SR)
+ (decode-E '(POP) 0))
+
+ (dispatch-on-bit ; 9
+ (register-op '(XCHG W (R 0)))
+ (dispatch-on-low-three-bits
+ (simple-inst '(CBW))
+ (simple-inst '(CWDE))
+ (decode-Ap '(CALL F))
+ (simple-inst '(WAIT))
+ (simple-inst '(PUSHF))
+ (simple-inst '(POPF))
+ (simple-inst '(SAHF))
+ (simple-inst '(LAHF))))
+
+ (dispatch-on-low-nibble ; A
+ (decode-@ '(MOV B (R 0)))
+ (decode-@ '(MOV W (R 0)))
+ (backwards
+ (decode-@ '(MOV B (R 0))))
+ (backwards
+ (decode-@ '(MOV W (R 0))))
+ (simple-inst '(MOVSB))
+ (simple-inst '(MOVSW))
+ (simple-inst '(CMPSB))
+ (simple-inst '(CMPSW))
+
+ (decode-Ib '(TEST B (R 0)))
+ (decode-Iw '(TEST W (R 0)))
+ (simple-inst '(STOS B))
+ (simple-inst '(STOS W))
+ (simple-inst '(LODS B))
+ (simple-inst '(LODS W))
+ (simple-inst '(SCAS B))
+ (simple-inst '(SCAS W)))
+\f
+ (dispatch-on-bit ; B
+ (lambda (opcode)
+ ((decode-Ib
+ `(MOV B (R ,(fix:and opcode #x7))))
+ opcode))
+ (lambda (opcode)
+ ((decode-Iw
+ `(MOV W (R ,(fix:and opcode #x7))))
+ opcode)))
+
+ (dispatch-on-low-nibble ; C
+ (group-1&2 shift-opcodes 'B immediate-byte)
+ (group-1&2 shift-opcodes 'W immediate-byte)
+ (decode-I16 '(RET))
+ (simple-inst '(RET))
+ (decode-G/M '(LES))
+ (decode-G/M '(LDS))
+ (decode-E/I '(MOV B) next-byte)
+ (decode-E/I '(MOV W) next-word)
+
+ decode-ENTER
+ (simple-inst '(LEAVE))
+ (decode-I16 '(RET F))
+ (simple-inst '(RET F))
+ (simple-inst '(INT 3))
+ (decode-Ib '(INT))
+ (simple-inst '(INTO))
+ (simple-inst '(IRET)))
+
+ (dispatch-on-bit ; D
+ (dispatch-on-low-three-bits
+ (group-1&2 shift-opcodes 'B (lambda () '(& 1)))
+ (group-1&2 shift-opcodes 'W (lambda () '(& 1)))
+ (group-1&2 shift-opcodes 'B (lambda () '(R 1)))
+ (group-1&2 shift-opcodes 'W (lambda () '(R 1)))
+ (simple-inst '(AAM))
+ (simple-inst '(AAD))
+ unknown-inst
+ (simple-inst '(XLAT)))
+ decode-fp)
+
+ (dispatch-on-low-nibble ; E
+ (decode-pcrb '(LOOPNE))
+ (decode-pcrb '(LOOPE))
+ (decode-pcrb '(LOOP))
+ (decode-pcrb '(JCXZ))
+ (decode-Ib '(IN B (R 0)))
+ (decode-Iw '(IN W (R 0)))
+ (backwards (decode-Ib '(OUT B (R 0))))
+ (backwards (decode-IW '(OUT W (R 0))))
+\f
+ (decode-pcrw '(CALL))
+ (decode-pcrw '(JMP W))
+ (decode-ap '(JMP F))
+ (decode-pcrb '(JMP B))
+ (simple-inst '(IN B (R 0) (R 2)))
+ (simple-inst '(IN W (R 0) (R 2)))
+ (simple-inst '(OUT B (R 2) (R 0)))
+ (simple-inst '(OUT W (R 2) (R 0))))
+
+ (dispatch-on-low-nibble ; F
+ (simple-inst '(LOCK))
+ unknown-inst
+ (simple-inst '(REPNE))
+ (simple-inst '(REPE))
+ (simple-inst '(HLT))
+ (simple-inst '(CMC))
+ (group-3 'B next-byte)
+ (group-3 'W next-word)
+
+ (simple-inst '(CLC))
+ (simple-inst '(STC))
+ (simple-inst '(CLI))
+ (simple-inst '(STI))
+ (simple-inst '(CLD))
+ (simple-inst '(STD))
+ (group-4 'B)
+ (group-5 'W)))))
+
+ (lambda ()
+ (let ((opcode-byte (next-unsigned-byte)))
+ ((vector-ref table (high-nibble opcode-byte))
+ opcode-byte)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: decls.scm,v 1.1 1995/01/10 20:52:36 adams Exp $
+
+Copyright (c) 1988-1994 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler File Dependencies
+;;; package: (compiler declarations)
+
+(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)
+ unspecific)
+
+(define (maybe-setup-source-nodes!)
+ (if (null? source-filenames)
+ (setup-source-nodes!)))
+
+(define (setup-source-nodes!)
+ (let ((filenames
+ (append-map!
+ (lambda (subdirectory)
+ (map (lambda (pathname)
+ (string-append subdirectory
+ "/"
+ (pathname-name pathname)))
+ (directory-read
+ (string-append subdirectory
+ "/"
+ source-file-expression))))
+ '("back" "base"
+ "midend"
+ "rtlbase"
+ "rtlopt"
+ "machines/i386"))))
+ (if (null? filenames)
+ (error "Can't find source files of compiler"))
+ (set! source-filenames filenames))
+ (set! source-hash (make-string-hash-table))
+ (set! source-nodes
+ (map (lambda (filename)
+ (let ((node (make/source-node filename)))
+ (hash-table/put! source-hash filename node)
+ node))
+ 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 (->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)
+ (let ((node (hash-table/get source-hash filename #f)))
+ (if (not node)
+ (error "Unknown source file:" filename))
+ node))
+
+(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))
+ unspecific)
+
+(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 (enough-namestring pathname))
+ (file-touch pathname))))
+
+(define (pathname-delete! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-string "\nDelete file: ")
+ (write (enough-namestring 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"
+ "toplev" "asstop" "crstop"
+ "cfg1" "cfg2" "cfg3" "constr"
+ "debug" "enumer"
+ "infnew"
+ "object" "pmerly"
+ "scode" "sets"
+ "stats"
+ "switch" "utils")
+ (filename/append "back"
+ "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
+ "lapgn2" "lapgn3" "linear" "regmap" "symtab"
+ "syntax")
+ (filename/append "machines/i386"
+ "dassm1" "insmac" "lapopt" "machin" "rgspcm"
+ "rulrew")
+ (filename/append "midend"
+ "alpha" "applicat" "assconv" "cleanup"
+ "closconv" "compat" "copier" "cpsconv"
+ "dataflow" "dbgstr" "debug" "earlyrew"
+ "envconv" "expand" "fakeprim" "graph"
+ "indexify" "inlate" "lamlift" "laterew"
+ "load" "midend" "rtlgen" "simplify"
+ "split" "stackopt" "staticfy" "synutl"
+ "triveval" "utils" "widen"
+ )
+ (filename/append "rtlbase"
+ "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
+ "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
+ "valclass"
+ ;; New stuff
+ "rtlpars"
+ ;; End of New stuff
+ )
+ (filename/append "rtlopt"
+ "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
+ "rcseht" "rcserq" "rcsesr" "rcsemrg"
+ "rdebug" "rdflow" "rerite" "rinvex"
+ "rlife" "rtlcsm"))
+ compiler-syntax-table)
+ (file-dependency/syntax/join
+ (filename/append "machines/i386"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo")
+ lap-generator-syntax-table)
+ (file-dependency/syntax/join
+ (filename/append "machines/i386" "insutl" "instr1" "instr2" "instrf")
+ 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"
+ "cfg1" "cfg2" "cfg3"
+ "enumer" "lvalue"
+ "object"
+ "scode"
+ "stats"
+ "utils"))
+ (midend-base
+ (filename/append "midend"
+ "fakeprim" "utils"))
+ (i386-base
+ (append (filename/append "machines/i386" "machin")
+ (filename/append "back" "asutl")))
+ (rtl-base
+ (filename/append "rtlbase"
+ "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
+ "rtlty2"))
+ (cse-base
+ (filename/append "rtlopt"
+ "rcse1" "rcseht" "rcserq" "rcsesr"))
+ (cse-all
+ (append (filename/append "rtlopt"
+ "rcse2" "rcsemrg" "rcseep")
+ cse-base))
+ (instruction-base
+ (filename/append "machines/i386" "assmd" "machin"))
+ (lapgen-base
+ (append (filename/append "back" "linear" "regmap")
+ (filename/append "machines/i386" "lapgen")))
+ (assembler-base
+ (append (filename/append "back" "symtab")
+ (filename/append "machines/i386" "insutl")))
+ (lapgen-body
+ (append
+ (filename/append "back" "lapgn1" "lapgn2" "syntax")
+ (filename/append "machines/i386"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo")))
+ (assembler-body
+ (append
+ (filename/append "back" "bittop")
+ (filename/append "machines/i386"
+ "instr1" "instr2" "instrf"))))
+
+ (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 "machines/i386" "machin" "back" "asutl")
+ (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 "machines/i386" "machin" "rtlbase"
+ "rtlreg" "rtlty1" "rtlty2")
+
+ (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rgraph" "machines/i386"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlcfg" "base"
+ "cfg1" "cfg2" "cfg3")
+ (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
+ (define-integration-dependencies "rtlbase" "rtlcon" "machines/i386"
+ "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/i386"
+ "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/i386"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
+
+ ;; New stuff
+ (file-dependency/integration/join (filename/append "rtlbase" "rtlpars")
+ rtl-base)
+ ;;(file-dependency/integration/join
+ ;; (filename/append "midend"
+ ;; "alpha" "applicat" "assconv" "cleanup"
+ ;; "closconv" "compat" "copier" "cpsconv"
+ ;; "dataflow" "dbgstr" "debug" "earlyrew"
+ ;; "envconv" "expand" "graph"
+ ;; "indexify" "inlate" "lamlift" "laterew"
+ ;; "load" "midend" "rtlgen" "simplify"
+ ;; "split" "stackopt" "staticfy" "synutl"
+ ;; "triveval" "widen")
+ ;; midend-base)
+
+ ;; End of new stuff
+
+ (file-dependency/integration/join
+ (append cse-all
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
+ "rerite" "rinvex" "rlife" "rtlcsm")
+ (filename/append "machines/i386" "rulrew"))
+ (append i386-base rtl-base))
+
+ (file-dependency/integration/join cse-all cse-base)
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
+ (filename/append "rtlbase" "regset"))
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "rcseht" "rcserq")
+ (filename/append "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"
+ "rgraph" "rtlcfg")
+ (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
+ (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
+ (cons 'RELATIVE
+ (make-list
+ (length (cdr (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/i386"
+ "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))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/inerly.scm,v 1.1 1995/01/10 20:52:37 adams Exp $
+$MC68020-Header: inerly.scm,v 1.6 88/08/31 06:00:59 GMT cph Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;; i386 Instruction Set Macros. Early version
+;;; NOPs for now.
+
+(declare (usual-integrations))
+\f
+;;;; Transformers and utilities
+
+(define early-instructions '())
+(define early-transformers '())
+
+(define (define-early-transformer name transformer)
+ (set! early-transformers
+ (cons (cons name transformer)
+ early-transformers)))
+
+(define (eq-subset? s1 s2)
+ (or (null? s1)
+ (and (memq (car s1) s2)
+ (eq-subset? (cdr s1) s2))))
+
+;;; Instruction and addressing mode macros
+
+(syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION
+ (macro (opcode . patterns)
+ `(SET! EARLY-INSTRUCTIONS
+ (CONS
+ (LIST ',opcode
+ ,@(map (lambda (pattern)
+ `(early-parse-rule
+ ',(car pattern)
+ (lambda (pat vars)
+ (early-make-rule
+ pat
+ vars
+ (scode-quote
+ (instruction->instruction-sequence
+ ,(parse-instruction (cadr pattern)
+ (cddr pattern)
+ true)))))))
+ patterns))
+ EARLY-INSTRUCTIONS))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/insmac.scm,v 1.1 1995/01/10 20:52:40 adams Exp $
+$Vax-Header: insmac.scm,v 1.12 89/05/17 20:29:15 GMT jinx Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Intel 386 Instruction Set Macros
+
+(declare (usual-integrations))
+\f
+;;;; Effective addressing
+
+(define ea-database-name
+ 'EA-DATABASE)
+
+(syntax-table-define assembler-syntax-table 'DEFINE-EA-DATABASE
+ (macro rules
+ `(DEFINE ,ea-database-name
+ ,(compile-database rules
+ (lambda (pattern actions)
+ (let ((keyword (car pattern))
+ (categories (car actions))
+ (mode (cadr actions))
+ (register (caddr actions))
+ (tail (cdddr actions)))
+ (declare (integrate keyword value))
+ `(MAKE-EFFECTIVE-ADDRESS
+ ',keyword
+ ',categories
+ ,(integer-syntaxer mode 'UNSIGNED 2)
+ ,(integer-syntaxer register 'UNSIGNED 3)
+ ,(process-tail tail false))))))))
+
+(define (process-tail tail early?)
+ (if (null? tail)
+ `()
+ (process-fields tail early?)))
+
+;; This one is necessary to distinguish between r/mW mW, etc.
+
+(syntax-table-define assembler-syntax-table 'DEFINE-EA-TRANSFORMER
+ (macro (name #!optional restriction)
+ (if (default-object? restriction)
+ `(define (,name expression)
+ (let ((match-result (pattern-lookup ,ea-database-name expression)))
+ (and match-result
+ (match-result))))
+ `(define (,name expression)
+ (let ((match-result (pattern-lookup ,ea-database-name expression)))
+ (and match-result
+ (let ((ea (match-result)))
+ (and (memq ',restriction (ea/categories ea))
+ ea))))))))
+\f
+;; *** We can't really handle switching these right now. ***
+
+(define-integrable *ADDRESS-SIZE* 32)
+(define-integrable *OPERAND-SIZE* 32)
+
+(define (parse-instruction opcode tail early?)
+ (process-fields (cons opcode tail) early?))
+
+(define (process-fields fields early?)
+ (if (and (null? (cdr fields))
+ (eq? (caar fields) 'VARIABLE-WIDTH))
+ (expand-variable-width (car fields) early?)
+ (expand-fields fields
+ early?
+ (lambda (code size)
+ (if (not (zero? (remainder size 8)))
+ (error "process-fields: bad syllable size" size))
+ code))))
+
+(define (expand-variable-width field early?)
+ (let ((binding (cadr field))
+ (clauses (cddr field)))
+ `(LIST
+ ,(variable-width-expression-syntaxer
+ (car binding) ; name
+ (cadr binding) ; expression
+ (map (lambda (clause)
+ (expand-fields
+ (cdr clause)
+ early?
+ (lambda (code size)
+ (if (not (zero? (remainder size 8)))
+ (error "expand-variable-width: bad clause size" size))
+ `(,code ,size ,@(car clause)))))
+ clauses)))))
+
+(define (collect-byte components tail receiver)
+ (define (inner components receiver)
+ (if (null? components)
+ (receiver tail 0)
+ (inner (cdr components)
+ (lambda (byte-tail byte-size)
+ (let ((size (caar components))
+ (expression (cadar components))
+ (type (if (null? (cddar components))
+ 'UNSIGNED
+ (caddar components))))
+ (receiver
+ `(CONS-SYNTAX
+ ,(integer-syntaxer expression type size)
+ ,byte-tail)
+ (+ size byte-size)))))))
+ (inner components receiver))
+\f
+(define (expand-fields fields early? receiver)
+ (if (null? fields)
+ (receiver ''() 0)
+ (expand-fields (cdr fields) early?
+ (lambda (tail tail-size)
+ (case (caar fields)
+ ;; For opcodes and fixed fields of the instruction
+ ((BYTE)
+ ;; (BYTE (8 #xff))
+ ;; (BYTE (16 (+ foo #x23) SIGNED))
+ (collect-byte (cdar fields)
+ tail
+ (lambda (code size)
+ (receiver code (+ size tail-size)))))
+ ((ModR/M)
+ ;; (ModR/M 2 source) = /2 r/m(source)
+ ;; (ModR/M r target) = /r r/m(target)
+ (if early?
+ (error "No early support for ModR/M -- Fix i386/insmac.scm")
+ (let ((field (car fields)))
+ (let ((digit-or-reg (cadr field))
+ (r/m (caddr field)))
+ (receiver
+ `(CONS-SYNTAX
+ (EA/REGISTER ,r/m)
+ (CONS-SYNTAX
+ ,(integer-syntaxer digit-or-reg 'UNSIGNED 3)
+ (CONS-SYNTAX
+ (EA/MODE ,r/m)
+ (APPEND-SYNTAX! (EA/EXTRA ,r/m)
+ ,tail))))
+ (+ 8 tail-size))))))
+ ;; For immediate operands whose size depends on the operand
+ ;; size for the instruction (halfword vs. longword)
+ ((IMMEDIATE)
+ (receiver
+ (let ((field (car fields)))
+ (let ((value (cadr field))
+ (mode (if (null? (cddr field))
+ 'OPERAND
+ (caddr field)))
+ (domain (if (or (null? (cddr field))
+ (null? (cdddr field)))
+ 'SIGNED
+ (cadddr field))))
+ `(CONS-SYNTAX
+ #|
+ (COERCE-TO-TYPE ,value
+ ,(case mode
+ ((OPERAND)
+ `*OPERAND-SIZE*)
+ ((ADDRESS)
+ `*ADDRESS-SIZE*)
+ (else
+ (error "Unknown IMMEDIATE mode" mode)))
+ ,domain)
+ |#
+ ,(integer-syntaxer
+ value
+ domain
+ (case mode
+ ((OPERAND)
+ *operand-size*)
+ ((ADDRESS)
+ *address-size*)
+ (else
+ (error "Unknown IMMEDIATE mode" mode))))
+ ,tail)))
+ tail-size))
+ (else
+ (error "expand-fields: Unknown field kind" (caar fields))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/instr1.scm,v 1.1 1995/01/10 20:52:41 adams Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Intel i386 Instruction Set, part I
+;;; package: (compiler lap-syntaxer)
+
+;; Some of the instructions have their operands ill-specified in the
+;; i486 book. Check against the appendices or the i386 book.
+
+(declare (usual-integrations))
+\f
+;; Utility
+
+(define-macro (define-trivial-instruction mnemonic opcode . extra)
+ `(define-instruction ,mnemonic
+ (()
+ (BYTE (8 ,opcode))
+ ,@(map (lambda (extra)
+ `(BYTE (8 ,extra)))
+ extra))))
+
+;;;; Pseudo ops
+
+(define-instruction BYTE
+ ((S (? value))
+ (BYTE (8 value SIGNED)))
+ ((U (? value))
+ (BYTE (8 value UNSIGNED))))
+
+(define-instruction WORD
+ ((S (? value))
+ (BYTE (16 value SIGNED)))
+ ((U (? value))
+ (BYTE (16 value UNSIGNED))))
+
+(define-instruction LONG
+ ((S (? value))
+ (BYTE (32 value SIGNED)))
+ ((U (? value))
+ (BYTE (32 value UNSIGNED))))
+\f
+;;;; Actual instructions
+
+(define-trivial-instruction AAA #x37)
+(define-trivial-instruction AAD #xd5 #x0a)
+(define-trivial-instruction AAM #xd4 #x0a)
+(define-trivial-instruction AAS #x3f)
+
+(let-syntax
+ ((define-arithmetic-instruction
+ (macro (mnemonic opcode digit)
+ `(define-instruction ,mnemonic
+ ((W (? target r/mW) (R (? source)))
+ (BYTE (8 ,(1+ opcode)))
+ (ModR/M source target))
+
+ ((W (R (? target)) (? source r/mW))
+ (BYTE (8 ,(+ opcode 3)))
+ (ModR/M target source))
+
+ ((W (? target r/mW) (& (? value sign-extended-byte)))
+ (BYTE (8 #x83))
+ (ModR/M ,digit target)
+ (BYTE (8 value SIGNED)))
+
+ ((W (R 0) (& (? value))) ; AX/EAX
+ (BYTE (8 ,(+ opcode 5)))
+ (IMMEDIATE value))
+
+ ((W (? target r/mW) (& (? value)))
+ (BYTE (8 #x81))
+ (ModR/M ,digit target)
+ (IMMEDIATE value))
+
+ ((W (? target r/mW) (&U (? value zero-extended-byte)))
+ (BYTE (8 #x83))
+ (ModR/M ,digit target)
+ (BYTE (8 value UNSIGNED)))
+
+ ((W (R 0) (&U (? value))) ; AX/EAX
+ (BYTE (8 ,(+ opcode 5)))
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((W (? target r/mW) (&U (? value)))
+ (BYTE (8 #x81))
+ (ModR/M ,digit target)
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((B (? target r/mB) (R (? source)))
+ (BYTE (8 ,opcode))
+ (ModR/M source target))
+
+ ((B (R (? target)) (? source r/mB))
+ (BYTE (8 ,(+ opcode 2)))
+ (ModR/M target source))
+
+ ((B (R 0) (& (? value))) ; AL
+ (BYTE (8 ,(+ opcode 4))
+ (8 value SIGNED)))
+
+ ((B (R 0) (&U (? value))) ; AL
+ (BYTE (8 ,(+ opcode 4))
+ (8 value UNSIGNED)))
+
+ ((B (? target r/mB) (& (? value)))
+ (BYTE (8 #x80))
+ (ModR/M ,digit target)
+ (BYTE (8 value SIGNED)))
+\f
+ ((B (? target r/mB) (&U (? value)))
+ (BYTE (8 #x80))
+ (ModR/M ,digit target)
+ (BYTE (8 value UNSIGNED)))))))
+
+ (define-arithmetic-instruction ADC #x10 2)
+ (define-arithmetic-instruction ADD #x00 0)
+ (define-arithmetic-instruction AND #x20 4)
+ (define-arithmetic-instruction CMP #x38 7)
+ (define-arithmetic-instruction OR #x08 1)
+ (define-arithmetic-instruction SBB #x18 3)
+ (define-arithmetic-instruction SUB #x28 5)
+ (define-arithmetic-instruction XOR #x30 6))
+
+(define-instruction ARPL
+ (((? target r/mW) (R (? source)))
+ (BYTE (8 #x63))
+ (ModR/M source target)))
+
+(define-instruction BOUND
+ (((R (? source)) (? bounds mW))
+ (BYTE (8 #x62))
+ (ModR/M source bounds)))
+
+(define-instruction BSF
+ (((R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #xbc))
+ (ModR/M target source)))
+
+(define-instruction BSR
+ (((R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #xbd))
+ (ModR/M target source)))
+
+(define-instruction BSWAP ; 486 only
+ (((R (? reg)))
+ (BYTE (8 #x0f)
+ (8 (+ #xc8 reg)))))
+
+(let-syntax
+ ((define-bit-test-instruction
+ (macro (mnemonic opcode digit)
+ `(define-instruction ,mnemonic
+ (((? target r/mW) (& (? posn)))
+ (BYTE (8 #x0f)
+ (8 #xba))
+ (ModR/M ,digit target)
+ (BYTE (8 posn UNSIGNED)))
+
+ (((? target r/mW) (R (? posn)))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M posn target))))))
+
+ (define-bit-test-instruction BT #xa3 4)
+ (define-bit-test-instruction BTC #xbb 7)
+ (define-bit-test-instruction BTR #xb3 6)
+ (define-bit-test-instruction BTS #xab 5))
+\f
+(define-instruction CALL
+ (((@PCR (? dest)))
+ (BYTE (8 #xe8))
+ (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
+
+ (((@PCRO (? dest) (? offset)))
+ (BYTE (8 #xe8))
+ (IMMEDIATE `(- (+ ,dest ,offset) (+ *PC* 4)) ADDRESS)); fcn(*ADDRESS-SIZE*)
+
+ (((@PCO (? displ)))
+ (BYTE (8 #xe8))
+ (IMMEDIATE displ ADDRESS))
+
+ (((? dest r/mW))
+ (BYTE (8 #xff))
+ (ModR/M 2 dest))
+
+ ((F (? dest mW))
+ (BYTE (8 #xff))
+ (ModR/M 3 dest))
+
+ ((F (SEGMENT (? seg)) (OFFSET (? off)))
+ (BYTE (8 #x9a))
+ (BYTE (16 seg))
+ (IMMEDIATE off ADDRESS)))
+
+(define-trivial-instruction CBW #x98)
+(define-trivial-instruction CWDE #x98)
+(define-trivial-instruction CLC #xf8)
+(define-trivial-instruction CLD #xfc)
+(define-trivial-instruction CLI #xfa)
+(define-trivial-instruction CLTS #x0f #x06)
+(define-trivial-instruction CMC #xf5)
+
+(let-syntax
+ ((define-string-instruction
+ (macro (mnemonic opcode)
+ `(define-instruction ,mnemonic
+ ((W)
+ (BYTE (8 ,(1+ opcode))))
+
+ ((B)
+ (BYTE (8 ,opcode)))))))
+
+ (define-string-instruction CMPS #xa6)
+ (define-string-instruction LODS #xac)
+ (define-string-instruction INS #x6c)
+ (define-string-instruction MOVS #xa4)
+ (define-string-instruction OUTS #x6e)
+ (define-string-instruction SCAS #xae)
+ (define-string-instruction STOS #xaa))
+
+(define-instruction CMPXCHG ; 486 only
+ ((W (? target r/mW) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #xa7))
+ (ModR/M reg target))
+
+ ((B (? target r/mB) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #xa6))
+ (ModR/M reg target)))
+
+(define-trivial-instruction CWD #x99)
+(define-trivial-instruction CDQ #x99)
+(define-trivial-instruction DAA #x27)
+(define-trivial-instruction DAS #x2f)
+\f
+(let-syntax
+ ((define-inc/dec
+ (macro (mnemonic digit opcode)
+ `(define-instruction ,mnemonic
+ ((W (R (? reg)))
+ (BYTE (8 (+ ,opcode reg))))
+
+ ((W (? target r/mW))
+ (BYTE (8 #xff))
+ (ModR/M ,digit target))
+
+ ((B (? target r/mB))
+ (BYTE (8 #xfe))
+ (ModR/M ,digit target))))))
+
+ (define-inc/dec DEC 1 #x48)
+ (define-inc/dec INC 0 #x40))
+
+(let-syntax
+ ((define-mul/div
+ (macro (mnemonic digit)
+ `(define-instruction ,mnemonic
+ ((W (R 0) (? operand r/mW))
+ (BYTE (8 #xf7))
+ (ModR/M ,digit operand))
+
+ ((B (R 0) (? operand r/mB))
+ (BYTE (8 #xf6))
+ (ModR/M ,digit operand))))))
+
+ (define-mul/div DIV 6)
+ (define-mul/div IDIV 7)
+ (define-mul/div MUL 4))
+
+(define-instruction ENTER
+ (((& (? frame-size)) (& (? lexical-level)))
+ (BYTE (8 #xc8)
+ (16 frame-size)
+ (8 lexical-level))))
+
+(define-trivial-instruction HLT #xf4)
+
+(define-instruction IMUL
+ ((W (R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #xaf))
+ (ModR/M target source))
+
+ ((W (R (? target)) (? source r/mW) (& (? value sign-extended-byte)))
+ (BYTE (8 #x6b))
+ (ModR/M target source)
+ (BYTE (8 value SIGNED)))
+
+ ((W (R (? target)) (? source r/mW) (& (? value)))
+ (BYTE (8 #x69))
+ (ModR/M target source)
+ (IMMEDIATE value))
+
+ ((W (R (? target)) (? source r/mW) (&U (? value zero-extended-byte)))
+ (BYTE (8 #x6b))
+ (ModR/M target source)
+ (BYTE (8 value UNSIGNED)))
+
+ ((W (R (? target)) (? source r/mW) (&U (? value)))
+ (BYTE (8 #x69))
+ (ModR/M target source)
+ (IMMEDIATE value OPERAND UNSIGNED))
+\f
+ ((W ((R 2) : (R 0)) (? source r/mW))
+ (BYTE (8 #xf7))
+ (ModR/M 5 source))
+
+ ((B (R 0) (? source r/mB))
+ (BYTE (8 #xf6))
+ (ModR/M 5 source)))
+
+(define-instruction IN
+ ((W (R 0) (& (? port)))
+ (BYTE (8 #xe5)
+ (8 port)))
+
+ ((W (R 0) (R 2))
+ (BYTE (8 #xed)))
+
+ ((B (R 0) (& (? port)))
+ (BYTE (8 #xe4)
+ (8 port)))
+
+ ((B (R 0) (R 2))
+ (BYTE (8 #xec))))
+
+(define-instruction INT
+ ((3)
+ (BYTE (8 #xcc)))
+
+ (((& (? vector)))
+ (BYTE (8 #xcd)
+ (8 vector))))
+
+(define-trivial-instruction INTO #xce)
+(define-trivial-instruction INVD #x0f #x08) ; 486 only
+(define-trivial-instruction IRET #xcf)
+
+(let-syntax
+ ((define-jump-instruction
+ (macro (mnemonic opcode1 opcode2)
+ `(define-instruction ,mnemonic
+ ;; This assumes that *ADDRESS-SIZE* is 4 (32-bit mode)
+ (((@PCR (? dest)))
+ (VARIABLE-WIDTH
+ (disp `(- ,dest (+ *PC* 2)))
+ ((-128 127)
+ (BYTE (8 ,opcode1)
+ (8 disp SIGNED)))
+ ((() ())
+ (BYTE (8 #x0f)
+ (8 ,opcode2)
+ (32 (- disp 4) SIGNED)))))
+
+ ((B (@PCR (? dest)))
+ (BYTE (8 ,opcode1)
+ (8 `(- ,dest (+ *PC* 1)) SIGNED)))
+
+ ((W (@PCR (? dest)))
+ (BYTE (8 #x0f)
+ (8 ,opcode2))
+ (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
+
+ ((B (@PCO (? displ)))
+ (BYTE (8 ,opcode1)
+ (8 displ SIGNED)))
+
+ ((W (@PCO (? displ)))
+ (BYTE (8 #x0f)
+ (8 ,opcode2))
+ (IMMEDIATE displ ADDRESS))))))
+\f
+ (define-jump-instruction JA #x77 #x87)
+ (define-jump-instruction JAE #x73 #x83)
+ (define-jump-instruction JB #x72 #x82)
+ (define-jump-instruction JBE #x76 #x86)
+ (define-jump-instruction JC #x72 #x82)
+ (define-jump-instruction JE #x74 #x84)
+ (define-jump-instruction JG #x7f #x8f)
+ (define-jump-instruction JGE #x7d #x8d)
+ (define-jump-instruction JL #x7c #x8c)
+ (define-jump-instruction JLE #x7e #x8e)
+ (define-jump-instruction JNA #x76 #x86)
+ (define-jump-instruction JNAE #x72 #x82)
+ (define-jump-instruction JNB #x73 #x83)
+ (define-jump-instruction JNBE #x77 #x87)
+ (define-jump-instruction JNC #x73 #x83)
+ (define-jump-instruction JNE #x75 #x85)
+ (define-jump-instruction JNG #x7e #x8e)
+ (define-jump-instruction JNGE #x7c #x8c)
+ (define-jump-instruction JNL #x7d #x8d)
+ (define-jump-instruction JNLE #x7f #x8f)
+ (define-jump-instruction JNO #x71 #x81)
+ (define-jump-instruction JNP #x7b #x8b)
+ (define-jump-instruction JNS #x79 #x89)
+ (define-jump-instruction JNZ #x75 #x85)
+ (define-jump-instruction JO #x70 #x80)
+ (define-jump-instruction JP #x7a #x8a)
+ (define-jump-instruction JPE #x7a #x8a)
+ (define-jump-instruction JPO #x7b #x8b)
+ (define-jump-instruction JS #x78 #x88)
+ (define-jump-instruction JZ #x74 #x84))
+
+(let-syntax
+ ((define-loop-instruction
+ (macro (mnemonic opcode)
+ `(define-instruction ,mnemonic
+ ((B (@PCR (? dest)))
+ (BYTE (8 ,opcode)
+ (8 `(- ,dest (+ *PC* 1)) SIGNED)))
+
+ ((B (@PCO (? displ)))
+ (BYTE (8 ,opcode)
+ (8 displ SIGNED)))))))
+
+ (define-loop-instruction JCXZ #xe3)
+ (define-loop-instruction JECXZ #xe3)
+ (define-loop-instruction LOOP #xe2)
+ (define-loop-instruction LOOPE #xe1)
+ (define-loop-instruction LOOPZ #xe1)
+ (define-loop-instruction LOOPNE #xe0)
+ (define-loop-instruction LOOPNZ #xe0))
+
+(define-instruction JMP
+ ;; This assumes that *ADDRESS-SIZE* is 4 (32-bit mode)
+ (((@PCR (? dest)))
+ (VARIABLE-WIDTH
+ (disp `(- ,dest (+ *PC* 2)))
+ ((-128 127)
+ (BYTE (8 #xeb)
+ (8 disp SIGNED)))
+ ((() ())
+ (BYTE (8 #xe9)
+ (32 (- disp 3) SIGNED)))))
+
+ (((@PCRO (? dest) (? offset)))
+ (VARIABLE-WIDTH
+ (disp `(- (+ ,dest ,offset) (+ *PC* 2)))
+ ((-128 127)
+ (BYTE (8 #xeb)
+ (8 disp SIGNED)))
+ ((() ())
+ (BYTE (8 #xe9)
+ (32 (- disp 3) SIGNED)))))
+
+ (((? dest r/mW))
+ (BYTE (8 #xff))
+ (ModR/M 4 dest))
+\f
+ ((B (@PCR (? dest)))
+ (BYTE (8 #xeb)
+ (8 `(- ,dest (+ *PC* 1)) SIGNED)))
+
+ ((W (@PCR (? dest)))
+ (BYTE (8 #xe9))
+ (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
+
+ ((B (@PCO (? displ)))
+ (BYTE (8 #xeb)
+ (8 displ SIGNED)))
+
+ ((W (@PCO (? displ)))
+ (BYTE (8 #xe9))
+ (IMMEDIATE displ ADDRESS))
+
+ ((F (? dest mW))
+ (BYTE (8 #xff))
+ (ModR/M 5 dest))
+
+ ((F (SEGMENT (? seg)) (OFFSET (? off)))
+ (BYTE (8 #xea))
+ (BYTE (16 seg))
+ (IMMEDIATE off ADDRESS)))
+
+(define-trivial-instruction LAHF #x9f)
+
+(define-instruction LAR
+ (((R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #x02))
+ (ModR/M target source)))
+
+(define-instruction LEA
+ (((R (? target)) (? source mW))
+ (BYTE (8 #x8d))
+ (ModR/M target source)))
+
+(define-trivial-instruction LEAVE #xc9)
+
+(let-syntax
+ ((define-load/store-state
+ (macro (mnemonic opcode digit)
+ `(define-instruction ,mnemonic
+ (((? operand mW))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M ,digit operand))))))
+
+ (define-load/store-state INVLPG #x01 7) ; 486 only
+ (define-load/store-state LGDT #x01 2)
+ (define-load/store-state LIDT #x01 3)
+ (define-load/store-state LLDT #x00 2)
+ (define-load/store-state LMSW #x01 6)
+ (define-load/store-state LTR #x00 3)
+ (define-load/store-state SGDT #x01 0)
+ (define-load/store-state SIDT #x01 1)
+ (define-load/store-state SLDT #x00 0)
+ (define-load/store-state SMSW #x01 4)
+ (define-load/store-state STR #x00 1)
+ (define-load/store-state VERR #x00 4)
+ (define-load/store-state VERW #x00 5))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/instr2.scm,v 1.1 1995/01/10 20:52:44 adams Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Intel i386 Instruction Set, part II
+;;; package: (compiler lap-syntaxer)
+
+;; Some of the instructions have their operands ill-specified in the
+;; i486 book. Check against the appendices or the i386 book.
+
+(declare (usual-integrations))
+
+;; Utility
+
+(define-macro (define-trivial-instruction mnemonic opcode . extra)
+ `(define-instruction ,mnemonic
+ (()
+ (BYTE (8 ,opcode))
+ ,@(map (lambda (extra)
+ `(BYTE (8 ,extra)))
+ extra))))
+\f
+;;;; Actual instructions
+
+(let-syntax
+ ((define-load-segment
+ (macro (mnemonic . bytes)
+ `(define-instruction ,mnemonic
+ (((R (? reg)) (? pointer mW))
+ (BYTE ,@(map (lambda (byte)
+ `(8 ,byte))
+ bytes))
+ (ModR/M reg pointer))))))
+
+ (define-load-segment LDS #xc5)
+ (define-load-segment LSS #x0f #xb2)
+ (define-load-segment LES #xc4)
+ (define-load-segment LFS #x0f #xb4)
+ (define-load-segment LGS #x0f #xb5))
+
+(define-instruction LSL
+ (((R (? reg)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #x03))
+ (ModR/M reg source)))
+
+(let-syntax
+ ((define-data-extension
+ (macro (mnemonic opcode)
+ `(define-instruction ,mnemonic
+ ((B (R (? target)) (? source r/mB))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M target source))
+
+ ((H (R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 ,(1+ opcode)))
+ (ModR/M target source))))))
+
+ (define-data-extension MOVSX #xbe)
+ (define-data-extension MOVZX #xb6))
+
+(let-syntax
+ ((define-unary
+ (macro (mnemonic digit)
+ `(define-instruction ,mnemonic
+ ((W (? operand r/mW))
+ (BYTE (8 #xf7))
+ (ModR/M ,digit operand))
+
+ ((B (? operand r/mB))
+ (BYTE (8 #xf6))
+ (ModR/M ,digit operand))))))
+
+ (define-unary NEG 3)
+ (define-unary NOT 2))
+\f
+(define-instruction MOV
+ ((W (R (? target)) (? source r/mW))
+ (BYTE (8 #x8b))
+ (ModR/M target source))
+
+ ((W (? target r/mW) (R (? source)))
+ (BYTE (8 #x89))
+ (ModR/M source target))
+
+ ((W (R (? reg)) (& (? value)))
+ (BYTE (8 (+ #xb8 reg)))
+ (IMMEDIATE value))
+
+ ((W (? target r/mW) (& (? value)))
+ (BYTE (8 #xc7))
+ (ModR/M 0 target)
+ (IMMEDIATE value))
+
+ ((W (R (? reg)) (&U (? value)))
+ (BYTE (8 (+ #xb8 reg)))
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((W (? target r/mW) (&U (? value)))
+ (BYTE (8 #xc7))
+ (ModR/M 0 target)
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((B (R (? target)) (? source r/mB))
+ (BYTE (8 #x8a))
+ (ModR/M target source))
+
+ ((B (? target r/mB) (R (? source)))
+ (BYTE (8 #x88))
+ (ModR/M source target))
+
+ ((B (R (? reg)) (& (? value)))
+ (BYTE (8 (+ #xb0 reg))
+ (8 value SIGNED)))
+
+ ((B (? target r/mB) (& (? value)))
+ (BYTE (8 #xc6))
+ (ModR/M 0 target)
+ (BYTE (8 value SIGNED)))
+
+ ((B (R (? reg)) (&U (? value)))
+ (BYTE (8 (+ #xb0 reg))
+ (8 value UNSIGNED)))
+
+ ((B (? target r/mB) (&U (? value)))
+ (BYTE (8 #xc6))
+ (ModR/M 0 target)
+ (BYTE (8 value UNSIGNED)))
+
+ ((W (R 0) (@ (? offset)))
+ (BYTE (8 #xa1))
+ (IMMEDIATE offset))
+
+ ((W (@ (? offset)) (R 0))
+ (BYTE (8 #xa3))
+ (IMMEDIATE offset))
+
+ ((B (R 0) (@ (? offset)))
+ (BYTE (8 #xa0)
+ (8 offset SIGNED)))
+
+ ((B (@ (? offset)) (R 0))
+ (BYTE (8 #xa2)
+ (8 offset SIGNED)))
+\f
+ (((? target r/mW) (SR (? source)))
+ (BYTE (8 #x8c))
+ (ModR/M source target))
+
+ (((SR (? target)) (? source r/mW))
+ (BYTE (8 #x8e))
+ (ModR/M target source))
+
+ (((CR (? creg)) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #x22))
+ (ModR/M creg `(R ,reg)))
+
+ (((R (? reg)) (CR (? creg)))
+ (BYTE (8 #x0f)
+ (8 #x20))
+ (ModR/M creg `(R ,reg)))
+
+ (((DR (? dreg)) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #x23))
+ (ModR/M dreg `(R ,reg)))
+
+ (((R (? reg)) (DR (? dreg)))
+ (BYTE (8 #x0f)
+ (8 #x21))
+ (ModR/M dreg `(R ,reg)))
+
+ (((TR (? treg)) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #x26))
+ (ModR/M treg `(R ,reg)))
+
+ (((R (? reg)) (TR (? treg)))
+ (BYTE (8 #x0f)
+ (8 #x24))
+ (ModR/M treg `(R ,reg))))
+\f
+(define-trivial-instruction NOP #x90)
+
+(define-instruction OUT
+ ((W (& (? port)) (R 0))
+ (BYTE (8 #xe7)
+ (8 port)))
+
+ ((W (R 2) (R 0))
+ (BYTE (8 #xef)))
+
+ ((B (& (? port)) (R 0))
+ (BYTE (8 #xe6)
+ (8 port)))
+
+ ((B (R 2) (R 0))
+ (BYTE (8 #xee))))
+
+(define-instruction POP
+ (((R (? target)))
+ (BYTE (8 (+ #x58 target))))
+
+ (((? target mW))
+ (BYTE (8 #x8f))
+ (ModR/M 0 target))
+
+ ((ES)
+ (BYTE (8 #x07)))
+
+ ((SS)
+ (BYTE (8 #x17)))
+
+ ((DS)
+ (BYTE (8 #x1f)))
+
+ ((FS)
+ (BYTE (8 #x0f)
+ (8 #xa1)))
+
+ ((GS)
+ (BYTE (8 #x0f)
+ (8 #xa9)))
+
+ (((SR 0))
+ (BYTE (8 #x07)))
+
+ (((SR 2))
+ (BYTE (8 #x17)))
+
+ (((SR 3))
+ (BYTE (8 #x1f)))
+
+ (((SR 4))
+ (BYTE (8 #x0f)
+ (8 #xa1)))
+
+ (((SR 5))
+ (BYTE (8 #x0f)
+ (8 #xa9))))
+
+(define-trivial-instruction POPA #x61)
+(define-trivial-instruction POPAD #x61)
+(define-trivial-instruction POPF #x9d)
+(define-trivial-instruction POPFD #x9d)
+\f
+(define-instruction PUSH
+ (((R (? source)))
+ (BYTE (8 (+ #x50 source))))
+
+ (((? source mW))
+ (BYTE (8 #xff))
+ (ModR/M 6 source))
+
+ ((W (& (? value)))
+ (BYTE (8 #x68))
+ (IMMEDIATE value))
+
+ ((W (&U (? value)))
+ (BYTE (8 #x68))
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((B (& (? value)))
+ (BYTE (8 #x6a)
+ (8 value)))
+
+ ((B (&U (? value)))
+ (BYTE (8 #x6a)
+ (8 value UNSIGNED)))
+
+ ((ES)
+ (BYTE (8 #x06)))
+
+ ((CS)
+ (BYTE (8 #x0e)))
+
+ ((SS)
+ (BYTE (8 #x16)))
+
+ ((DS)
+ (BYTE (8 #x1e)))
+
+ ((FS)
+ (BYTE (8 #x0f)
+ (8 #xa0)))
+
+ ((GS)
+ (BYTE (8 #x0f)
+ (8 #xa8)))
+
+ (((SR 0))
+ (BYTE (8 #x06)))
+
+ (((SR 1))
+ (BYTE (8 #x0e)))
+
+ (((SR 2))
+ (BYTE (8 #x16)))
+
+ (((SR 3))
+ (BYTE (8 #x1e)))
+
+ (((SR 4))
+ (BYTE (8 #x0f)
+ (8 #xa0)))
+
+ (((SR 5))
+ (BYTE (8 #x0f)
+ (8 #xa8))))
+
+(define-trivial-instruction PUSHA #x60)
+(define-trivial-instruction PUSHAD #x60)
+(define-trivial-instruction PUSHF #x9c)
+(define-trivial-instruction PUSHFD #x9c)
+\f
+(let-syntax
+ ((define-rotate/shift
+ (macro (mnemonic digit)
+ `(define-instruction ,mnemonic
+ ((W (? operand r/mW) (& 1))
+ (BYTE (8 #xd1))
+ (ModR/M ,digit operand))
+
+ ((W (? operand r/mW) (& (? value)))
+ (BYTE (8 #xc1))
+ (ModR/M ,digit operand)
+ (BYTE (8 value)))
+
+ ((W (? operand r/mW) (R 1))
+ (BYTE (8 #xd3))
+ (ModR/M ,digit operand))
+
+ ((B (? operand r/mB) (& 1))
+ (BYTE (8 #xd0))
+ (ModR/M ,digit operand))
+
+ ((B (? operand r/mB) (& (? value)))
+ (BYTE (8 #xc0))
+ (ModR/M ,digit operand)
+ (BYTE (8 value)))
+
+ ((B (? operand r/mB) (R 1))
+ (BYTE (8 #xd2))
+ (ModR/M ,digit operand))))))
+
+ (define-rotate/shift RCL 2)
+ (define-rotate/shift RCR 3)
+ (define-rotate/shift ROL 0)
+ (define-rotate/shift ROR 1)
+ (define-rotate/shift SAL 4)
+ (define-rotate/shift SAR 7)
+ (define-rotate/shift SHL 4)
+ (define-rotate/shift SHR 5))
+
+(let-syntax
+ ((define-double-shift
+ (macro (mnemonic opcode)
+ `(define-instruction ,mnemonic
+ ((W (? target r/mW) (R (? source)) (& (? count)))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M target source)
+ (BYTE (8 count)))
+
+ ((W (? target r/mW) (R (? source)) (R 1))
+ (BYTE (8 #x0f)
+ (8 ,(1+ opcode)))
+ (ModR/M target source))))))
+
+ (define-double-shift SHLD #xa4)
+ (define-double-shift SHRD #xac))
+\f
+(define-instruction RET
+ (()
+ (BYTE (8 #xc3)))
+
+ ((F)
+ (BYTE (8 #xcb)))
+
+ (((& (? frame-size)))
+ (BYTE (8 #xc2)
+ (16 frame-size)))
+
+ ((F (& (? frame-size)))
+ (BYTE (8 #xca)
+ (16 frame-size))))
+
+(define-trivial-instruction SAHF #x9e)
+
+(let-syntax
+ ((define-setcc-instruction
+ (macro (mnemonic opcode)
+ `(define-instruction ,mnemonic
+ (((? target r/mB))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M 0 target)))))) ; 0?
+
+ (define-setcc-instruction SETA #x97)
+ (define-setcc-instruction SETAE #x93)
+ (define-setcc-instruction SETB #x92)
+ (define-setcc-instruction SETBE #x96)
+ (define-setcc-instruction SETC #x92)
+ (define-setcc-instruction SETE #x94)
+ (define-setcc-instruction SETG #x9f)
+ (define-setcc-instruction SETGE #x9d)
+ (define-setcc-instruction SETL #x9c)
+ (define-setcc-instruction SETLE #x9e)
+ (define-setcc-instruction SETNA #x96)
+ (define-setcc-instruction SETNAE #x92)
+ (define-setcc-instruction SETNB #x93)
+ (define-setcc-instruction SETNBE #x97)
+ (define-setcc-instruction SETNC #x93)
+ (define-setcc-instruction SETNE #x95)
+ (define-setcc-instruction SETNG #x9e)
+ (define-setcc-instruction SETNGE #x9c)
+ (define-setcc-instruction SETNL #x9d)
+ (define-setcc-instruction SETNLE #x9f)
+ (define-setcc-instruction SETNO #x91)
+ (define-setcc-instruction SETNP #x9b)
+ (define-setcc-instruction SETNS #x99)
+ (define-setcc-instruction SETNZ #x95)
+ (define-setcc-instruction SETO #x90)
+ (define-setcc-instruction SETP #x9a)
+ (define-setcc-instruction SETPE #x9a)
+ (define-setcc-instruction SETPO #x9b)
+ (define-setcc-instruction SETS #x98)
+ (define-setcc-instruction SETZ #x94))
+\f
+(define-trivial-instruction STC #xf9)
+(define-trivial-instruction STD #xfd)
+(define-trivial-instruction STI #xfb)
+
+(define-instruction TEST
+ ((W (? op1 r/mW) (R (? op2)))
+ (BYTE (8 #x85))
+ (ModR/M op2 op1))
+
+ ((W (R 0) (& (? value)))
+ (BYTE (8 #xa9))
+ (IMMEDIATE value))
+
+ ((W (R 0) (&U (? value)))
+ (BYTE (8 #xa9))
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((W (? op1 r/mW) (& (? value)))
+ (BYTE (8 #xf7))
+ (ModR/M 0 op1)
+ (IMMEDIATE value))
+
+ ((W (? op1 r/mW) (&U (? value)))
+ (BYTE (8 #xf7))
+ (ModR/M 0 op1)
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((B (? op1 r/mB) (R (? op2)))
+ (BYTE (8 #x84))
+ (ModR/M op2 op1))
+
+ ((B (R 0) (& (? value)))
+ (BYTE (8 #xa8)
+ (8 value SIGNED)))
+
+ ((B (R 0) (&U (? value)))
+ (BYTE (8 #xa8)
+ (8 value UNSIGNED)))
+
+ ((B (? op1 r/mB) (& (? value)))
+ (BYTE (8 #xf6))
+ (ModR/M 0 op1)
+ (BYTE (8 value SIGNED)))
+
+ ((B (? op1 r/mB) (&U (? value)))
+ (BYTE (8 #xf6))
+ (ModR/M 0 op1)
+ (BYTE (8 value UNSIGNED))))
+\f
+(define-trivial-instruction WAIT #x9b) ; = (FWAIT)
+(define-trivial-instruction WBINVD #x0f #x09) ; 486 only
+
+(define-instruction XADD ; 486 only
+ ((W (? target r/mW) (R (? source)))
+ (BYTE (8 #x0f)
+ (8 #xc1))
+ (ModR/M source target))
+
+ ((B (? target r/mB) (R (? source)))
+ (BYTE (8 #x0f)
+ (8 #xc0))
+ (ModR/M source target)))
+
+(define-instruction XCHG
+ ((W (R 0) (R (? reg)))
+ (BYTE (8 (+ #x90 reg))))
+
+ ((W (R (? reg)) (R 0))
+ (BYTE (8 (+ #x90 reg))))
+
+ ((W (R (? reg)) (? op r/mW))
+ (BYTE (8 #x87))
+ (ModR/M reg op))
+
+ ((W (? op r/mW) (R (? reg)))
+ (BYTE (8 #x87))
+ (ModR/M reg op))
+
+ ((B (R (? reg)) (? op r/mB))
+ (BYTE (8 #x86))
+ (ModR/M reg op))
+
+ ((B (? op r/mB) (R (? reg)))
+ (BYTE (8 #x86))
+ (ModR/M reg op)))
+
+(define-trivial-instruction XLAT #xd7)
+\f
+;;;; Instruction prefixes. Treated as separate instructions.
+
+(define-trivial-instruction LOCK #xf0)
+
+(define-trivial-instruction REP #xf3) ; or #xf2 trust which appendix?
+(define-trivial-instruction REPE #xf3)
+(define-trivial-instruction REPNE #xf2)
+(define-trivial-instruction REPNZ #xf2)
+(define-trivial-instruction REPZ #xf3)
+
+(define-trivial-instruction CSSEG #x2e)
+(define-trivial-instruction SSSEG #x36)
+(define-trivial-instruction DSSEG #x3e)
+(define-trivial-instruction ESSEG #x26)
+(define-trivial-instruction FSSEG #x64)
+(define-trivial-instruction GSSEG #x65)
+
+;; **** These are broken. The assembler needs to change state, i.e.
+;; fluid-let *OPERAND-SIZE* or *ADDRESS-SIZE*. ****
+
+(define-trivial-instruction OPSIZE #x66)
+(define-trivial-instruction ADSIZE #x67)
+
+;; **** Missing MOV instruction to/from special registers. ****
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/instrf.scm,v 1.1 1995/01/10 20:52:52 adams Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Intel i387/i486 Instruction Set
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(let-syntax
+ ((define-binary-flonum
+ (macro (mnemonic pmnemonic imnemonic digit opcode1 opcode2)
+ `(begin
+ (define-instruction ,mnemonic
+ (((ST 0) (ST (? i)))
+ (BYTE (8 #xd8)
+ (8 (+ ,opcode1 i))))
+
+ (((ST (? i)) (ST 0))
+ (BYTE (8 #xdc)
+ (8 (+ ,opcode2 i))))
+
+ (()
+ (BYTE (8 #xde)
+ (8 (+ ,opcode2 1))))
+
+ ((D (? source mW))
+ (BYTE (8 #xdc))
+ (ModR/M ,digit source))
+
+ ((S (? source mW))
+ (BYTE (8 #xd8))
+ (ModR/M ,digit source)))
+
+ (define-instruction ,pmnemonic
+ (((ST (? i)) (ST 0))
+ (BYTE (8 #xde)
+ (8 (+ ,opcode2 i)))))
+
+ (define-instruction ,imnemonic
+ ((L (? source mW))
+ (BYTE (8 #xda))
+ (ModR/M ,digit source))
+
+ ((H (? source mW))
+ (BYTE (8 #xde))
+ (ModR/M ,digit source)))))))
+
+ ;; The i486 book (and 387, etc.) has inconsistent instruction
+ ;; descriptions and opcode assignments for FSUB and siblings,
+ ;; and FDIV and siblings.
+ ;; FSUB ST(i),ST is described as replacing ST(i) with ST-ST(i)
+ ;; while the opcode described replaces ST(i) with ST(i)-ST.
+
+ ;; In the following, the F% forms follow the descriptions in the
+ ;; book, namely, F%SUB computes ST-ST(i) and F%SUBR computes
+ ;; ST(i)-ST, storing into their destination (first) argument.
+
+ ;; The %-less forms follow the opcodes and usual convention,
+ ;; namely FSUB computes destination (first) argument - source
+ ;; argument FSUBR computes source - destination.
+
+ (define-binary-flonum FADD FADDP FIADD 0 #xc0 #xc0)
+ (define-binary-flonum F%DIV F%DIVP F%IDIV 6 #xf0 #xf0)
+ (define-binary-flonum F%DIVR F%DIVPR F%IDIVR 7 #xf8 #xf8)
+ (define-binary-flonum FDIV FDIVP FIDIV 6 #xf0 #xf8)
+ (define-binary-flonum FDIVR FDIVPR FIDIVR 7 #xf8 #xf0)
+ (define-binary-flonum FMUL FMULP FIMUL 1 #xc8 #xc8)
+ (define-binary-flonum F%SUB F%SUBP F%ISUB 4 #xe0 #xe0)
+ (define-binary-flonum F%SUBR F%SUBPR F%ISUBR 5 #xe8 #xe8)
+ (define-binary-flonum FSUB FSUBP FISUB 4 #xe0 #xe8)
+ (define-binary-flonum FSUBR FSUBPR FISUBR 5 #xe8 #xe0))
+\f
+(define-macro (define-trivial-instruction mnemonic opcode . extra)
+ `(define-instruction ,mnemonic
+ (()
+ (BYTE (8 ,opcode))
+ ,@(map (lambda (extra)
+ `(BYTE (8 ,extra)))
+ extra))))
+
+(define-trivial-instruction F2XM1 #xd9 #xf0)
+(define-trivial-instruction FABS #xd9 #xe1)
+
+(define-instruction FBLD
+ (((? source mW))
+ (BYTE (8 #xd8))
+ (ModR/M 4 source)))
+
+(define-instruction FBSTP
+ (((? target mW))
+ (BYTE (8 #xdf))
+ (ModR/M 6 target)))
+
+(define-trivial-instruction FCHS #xd9 #xe0)
+(define-trivial-instruction FCLEX #x9b #xdb #xe2) ; = (FWAIT) (FNCLEX)
+(define-trivial-instruction FNCLEX #xdb #xe2)
+
+(let-syntax
+ ((define-flonum-comparison
+ (macro (mnemonic digit opcode)
+ `(define-instruction ,mnemonic
+ (((ST 0) (ST (? i)))
+ (BYTE (8 #xd8)
+ (8 (+ ,opcode i))))
+
+ (()
+ (BYTE (8 #xd8)
+ (8 (+ ,opcode 1))))
+
+ ((D (? source mW))
+ (BYTE (8 #xdc))
+ (ModR/M ,digit source))
+
+ ((S (? source mW))
+ (BYTE (8 #xd8))
+ (ModR/M ,digit source))))))
+
+ (define-flonum-comparison FCOM 2 #xd0)
+ (define-flonum-comparison FCOMP 3 #xd8))
+
+(define-trivial-instruction FCOMPP #xde #xd9)
+(define-trivial-instruction FCOS #xd9 #xff)
+(define-trivial-instruction FDECSTP #xd9 #xf6)
+
+(define-instruction FFREE
+ (((ST (? i)))
+ (BYTE (8 #xdd)
+ (8 (+ #xc0 i)))))
+
+(let-syntax
+ ((define-flonum-integer-comparison
+ (macro (mnemonic digit)
+ `(define-instruction ,mnemonic
+ ((L (? source mW))
+ (BYTE (8 #xda))
+ (ModR/M ,digit source))
+
+ ((H (? source mW))
+ (BYTE (8 #xde))
+ (ModR/M ,digit source))))))
+
+ (define-flonum-integer-comparison FICOM 2)
+ (define-flonum-integer-comparison FICOMP 3))
+
+(let-syntax
+ ((define-flonum-integer-memory
+ (macro (mnemonic digit1 digit2)
+ `(define-instruction ,mnemonic
+ ,@(if (not digit2)
+ `()
+ `(((Q (? source mW))
+ (BYTE (8 #xdf))
+ (ModR/M ,digit2 source))))
+
+ ((L (? source mW))
+ (BYTE (8 #xdb))
+ (ModR/M ,digit1 source))
+
+ ((H (? source mW))
+ (BYTE (8 #xdf))
+ (ModR/M ,digit1 source))))))
+
+ (define-flonum-integer-memory FILD 0 5)
+ (define-flonum-integer-memory FIST 2 #f)
+ (define-flonum-integer-memory FISTP 3 7))
+
+(define-trivial-instruction FINCSTP #xd9 #xf7)
+(define-trivial-instruction FINIT #x9b #xdb #xe3) ; = (FWAIT) (FNINT)
+(define-trivial-instruction FNINIT #xdb #xe3)
+
+(let-syntax
+ ((define-flonum-memory
+ (macro (mnemonic digit1 digit2 opcode1 opcode2)
+ `(define-instruction ,mnemonic
+ (((ST (? i)))
+ (BYTE (8 ,opcode1)
+ (8 (+ ,opcode2 i))))
+
+ ((D (? operand mW))
+ (BYTE (8 #xdd))
+ (ModR/M ,digit1 operand))
+
+ ((S (? operand mW))
+ (BYTE (8 #xd9))
+ (ModR/M ,digit1 operand))
+
+ ,@(if (not digit2)
+ `()
+ `(((X (? operand mW))
+ (BYTE (8 #xdb))
+ (ModR/M ,digit2 operand))))))))
+
+ (define-flonum-memory FLD 0 5 #xd9 #xc0)
+ (define-flonum-memory FST 2 #f #xdd #xd0)
+ (define-flonum-memory FSTP 3 7 #xdd #xd8))
+
+(define-trivial-instruction FLD1 #xd9 #xe8)
+(define-trivial-instruction FLDL2T #xd9 #xe9)
+(define-trivial-instruction FLDL2E #xd9 #xea)
+(define-trivial-instruction FLDPI #xd9 #xeb)
+(define-trivial-instruction FLDLG2 #xd9 #xec)
+(define-trivial-instruction FLDLN2 #xd9 #xed)
+(define-trivial-instruction FLDZ #xd9 #xee)
+
+(let-syntax
+ ((define-flonum-state
+ (macro (mnemonic opcode digit mnemonic2)
+ `(begin
+ ,@(if (not mnemonic2)
+ `()
+ `((define-instruction ,mnemonic2
+ (((? source mW))
+ (BYTE (8 #x9b) ; (FWAIT)
+ (8 ,opcode))
+ (ModR/M ,digit source)))))
+
+ (define-instruction ,mnemonic
+ (((? source mW))
+ (BYTE (8 ,opcode))
+ (ModR/M ,digit source)))))))
+
+ (define-flonum-state FNLDCW #xd9 5 FLDCW)
+ (define-flonum-state FLDENV #xd9 4 #f)
+ (define-flonum-state FNSTCW #xd9 7 FSTCW)
+ (define-flonum-state FNSTENV #xd9 6 FSTENV)
+ (define-flonum-state FRSTOR #xdb 4 #f)
+ (define-flonum-state FNSAVE #xdd 6 FSAVE))
+
+(define-trivial-instruction FNOP #xd9 #xd0)
+(define-trivial-instruction FPATAN #xd9 #xf3)
+(define-trivial-instruction FPREM #xd9 #xf8) ; truncating remainder
+(define-trivial-instruction FPREM1 #xd9 #xf5) ; IEEE remainder
+(define-trivial-instruction FPTAN #xd9 #xf2)
+(define-trivial-instruction FRNDINT #xd9 #xfc)
+(define-trivial-instruction FSCALE #xd9 #xfd)
+(define-trivial-instruction FSIN #xd9 #xfe)
+(define-trivial-instruction FSINCOS #xd9 #xfb)
+(define-trivial-instruction FSQRT #xd9 #xfa)
+
+(define-instruction FSTSW
+ (((? target mW))
+ (BYTE (8 #x9b) ; (FWAIT)
+ (8 #xdf))
+ (ModR/M 7 target))
+
+ (((R 0))
+ (BYTE (8 #x9b) ; (FWAIT)
+ (8 #xdf)
+ (8 #xe0))))
+
+(define-instruction FNSTSW
+ (((? target mW))
+ (BYTE (8 #xdf))
+ (ModR/M 7 target))
+
+ (((R 0))
+ (BYTE (8 #xdf)
+ (8 #xe0))))
+
+(define-trivial-instruction FTST #xd9 #xe4)
+
+(let-syntax
+ ((define-binary-flonum
+ (macro (mnemonic opcode1 opcode2)
+ `(define-instruction ,mnemonic
+ (((ST 0) (ST (? i)))
+ (BYTE (8 ,opcode1)
+ (8 (+ ,opcode2 i))))
+
+ (()
+ (BYTE (8 ,opcode1)
+ (8 (+ ,opcode2 1))))))))
+
+ (define-binary-flonum FUCOM #xdd #xe0)
+ (define-binary-flonum FUCOMP #xdd #xe8)
+ (define-binary-flonum FXCH #xd9 #xc8))
+
+(define-trivial-instruction FUCOMPP #xda #xe9)
+(define-trivial-instruction FWAIT #x9b)
+(define-trivial-instruction FXAM #xd9 #xe5)
+(define-trivial-instruction FXTRACT #xd9 #xf4)
+(define-trivial-instruction FYL2X #xd9 #xf1)
+(define-trivial-instruction FYL2XP1 #xd9 #xf9)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/insutl.scm,v 1.1 1995/01/10 20:52:56 adams Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Intel 386 Instruction Set, utilities
+
+(declare (usual-integrations))
+\f
+;;;; Addressing modes
+
+;; r/m part of ModR/M byte and SIB byte.
+;; These are valid only for 32-bit addressing.
+
+(define-ea-database
+ ((R (? r))
+ (REGISTER)
+ #b11 r)
+
+ ((@R (? r indirect-reg))
+ (MEMORY)
+ #b00 r)
+
+ ((@R 5) ; EBP
+ (MEMORY)
+ #b01 5
+ (BYTE (8 0)))
+
+ ((@R 4) ; ESP
+ (MEMORY)
+ #b00 4
+ (BYTE (3 4)
+ (3 4)
+ (2 0)))
+
+ ((@RO B (? r index-reg) (? offset))
+ (MEMORY)
+ #b01 r
+ (BYTE (8 offset SIGNED)))
+
+ ((@RO UB (? r index-reg) (? offset))
+ (MEMORY)
+ #b01 r
+ (BYTE (8 offset UNSIGNED)))
+
+ ((@RO B 4 (? offset))
+ (MEMORY)
+ #b01 4
+ (BYTE (3 4)
+ (3 4)
+ (2 0)
+ (8 offset SIGNED)))
+
+ ((@RO UB 4 (? offset))
+ (MEMORY)
+ #b01 4
+ (BYTE (3 4)
+ (3 4)
+ (2 0)
+ (8 offset UNSIGNED)))
+
+ ((@RO W (? r index-reg) (? offset))
+ (MEMORY)
+ #b10 r
+ (IMMEDIATE offset ADDRESS SIGNED))
+
+ ((@RO UW (? r index-reg) (? offset))
+ (MEMORY)
+ #b10 r
+ (IMMEDIATE offset ADDRESS UNSIGNED))
+\f
+ ((@RO W 4 (? offset)) ; ESP
+ (MEMORY)
+ #b10 #b100
+ (BYTE (3 4)
+ (3 4)
+ (2 0))
+ (IMMEDIATE offset ADDRESS SIGNED))
+
+ ((@RO UW 4 (? offset)) ; ESP
+ (MEMORY)
+ #b10 #b100
+ (BYTE (3 4)
+ (3 4)
+ (2 0))
+ (IMMEDIATE offset ADDRESS UNSIGNED))
+
+ ((@RI (? b base-reg) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b00 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s)))
+
+ ((@RI 5 (? i index-reg) (? s index-scale)) ; EBP
+ (MEMORY)
+ #b01 #b100
+ (BYTE (3 5)
+ (3 i)
+ (2 s)
+ (8 0)))
+
+ ((@ROI B (? b) (? offset) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b01 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s)
+ (8 offset SIGNED)))
+
+ ((@ROI UB (? b) (? offset) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b01 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s)
+ (8 offset UNSIGNED)))
+
+ ((@ROI W (? b) (? offset) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b10 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s))
+ (IMMEDIATE offset ADDRESS SIGNED))
+
+ ((@ROI UW (? b) (? offset) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b10 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s))
+ (IMMEDIATE offset ADDRESS UNSIGNED))
+
+ ((@ (? value))
+ (MEMORY)
+ #b00 #b101
+ (IMMEDIATE value ADDRESS)))
+\f
+(define-ea-transformer r/mW)
+(define-ea-transformer mW MEMORY)
+(define-ea-transformer r/mB)
+(define-ea-transformer mB MEMORY)
+
+(define-structure (effective-address
+ (conc-name ea/)
+ (constructor make-effective-address))
+ (keyword false read-only true)
+ (categories false read-only true)
+ (mode false read-only true)
+ (register false read-only true)
+ (extra '() read-only true))
+
+(define (sign-extended-byte value)
+ (and (fits-in-signed-byte? value)
+ value))
+
+(define (zero-extended-byte value)
+ (and (fits-in-unsigned-byte? value)
+ value))
+
+(define-integrable (indirect-reg r)
+ (and (not (= r esp))
+ (not (= r ebp))
+ r))
+
+(define-integrable (base-reg r)
+ (and (not (= r ebp))
+ r))
+
+(define-integrable (index-reg r)
+ (and (not (= r esp))
+ r))
+
+(define (index-scale scale-value)
+ (case scale-value
+ ((1) #b00)
+ ((2) #b01)
+ ((4) #b10)
+ ((8) #b11)
+ (else false)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: lapgen.scm,v 1.1 1995/01/10 20:52:58 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rules utilities for i386 and family.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Register-Allocator Interface
+
+(define available-machine-registers
+ ;; esp holds the the stack pointer
+ ;; ebp holds the pointer mask
+ ;; esi holds the register array pointer
+ ;; edi holds the free pointer
+ ;; fr7 is not used so that we can always push on the stack once.
+ (list eax ecx edx ebx fr0 fr1 fr2 fr3 fr4 fr5 fr6))
+
+(define-integrable (sort-machine-registers registers)
+ registers)
+
+(define (register-type register)
+ (cond ((machine-register? register)
+ (vector-ref
+ '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ 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-types-compatible? type1 type2)
+ (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
+
+(define register-reference
+ (let ((references (make-vector number-of-machine-registers)))
+ (let loop ((i 0))
+ (cond ((>= i number-of-machine-registers)
+ (lambda (register)
+ (vector-ref references register)))
+ ((< i 8)
+ (vector-set! references i (INST-EA (R ,i)))
+ (loop (1+ i)))
+ (else
+ (vector-set! references i (INST-EA (ST ,(floreg->sti i))))
+ (loop (1+ i)))))))
+
+(define (register->register-transfer source target)
+ (machine->machine-register source target))
+
+(define (reference->register-transfer source target)
+ (cond ((equal? (register-reference target) source)
+ (LAP))
+ ((float-register-reference? source)
+ ;; Assume target is a float register
+ (LAP (FLD ,source)))
+ (else
+ (memory->machine-register source target))))
+
+(define-integrable (pseudo-register-home register)
+ (offset-reference regnum:regs-pointer
+ (pseudo-register-offset register)))
+
+(define (home->register-transfer source target)
+ (pseudo->machine-register source target))
+
+(define (register->home-transfer source target)
+ (machine->pseudo-register source target))
+
+(define-integrable (float-register-reference? ea)
+ (and (pair? ea)
+ (eq? (car ea) 'ST)))
+\f
+;;;; Linearizer interface
+
+(define (lap:make-label-statement label)
+ (LAP (LABEL ,label)))
+
+(define (lap:make-unconditional-branch label)
+ (LAP (JMP (@PCR ,label))))
+
+(define (lap:make-entry-point label block-start-label)
+ block-start-label
+ (LAP (ENTRY-POINT ,label)
+ ,@(make-external-label expression-code-word label)))
+
+(define (make-external-label code label)
+ (set! *external-labels* (cons label *external-labels*))
+ (LAP (WORD U ,code)
+ (BLOCK-OFFSET ,label)
+ (LABEL ,label)))
+
+(define-integrable (make-code-word min max)
+ (+ (* #x100 min) max))
+
+(define expression-code-word
+ (make-code-word #xff #xff))
+\f
+;;;; Utilities for the register allocator interface
+
+(define-integrable (machine->machine-register source target)
+ (if (not (register-types-compatible? source target))
+ (error "Moving between incompatible register types" source target))
+ (if (not (float-register? source))
+ (LAP (MOV W ,(register-reference target) ,(register-reference source)))
+ (let ((ssti (floreg->sti source))
+ (tsti (floreg->sti target)))
+ (if (zero? ssti)
+ (LAP (FST (ST ,tsti)))
+ (LAP (FLD (ST ,ssti))
+ (FSTP (ST ,(1+ tsti))))))))
+
+(define (machine-register->memory source target)
+ (if (not (float-register? source))
+ (LAP (MOV W ,target ,(register-reference source)))
+ (let ((ssti (floreg->sti source)))
+ (if (zero? ssti)
+ (LAP (FST D ,target))
+ (LAP (FLD (ST ,ssti))
+ (FSTP D ,target))))))
+
+(define (memory->machine-register source target)
+ (if (not (float-register? target))
+ (LAP (MOV W ,(register-reference target) ,source))
+ (LAP (FLD D ,source)
+ (FSTP (ST ,(1+ (floreg->sti target)))))))
+
+(define-integrable (offset-reference register offset)
+ (byte-offset-reference register (* 4 offset)))
+
+(define (byte-offset-reference register offset)
+ (cond ((zero? offset)
+ (INST-EA (@R ,register)))
+ ((fits-in-signed-byte? offset)
+ (INST-EA (@RO B ,register ,offset)))
+ (else
+ (INST-EA (@RO W ,register ,offset)))))
+
+(define (byte-unsigned-offset-reference register offset)
+ (cond ((zero? offset)
+ (INST-EA (@R ,register)))
+ ((fits-in-unsigned-byte? offset)
+ (INST-EA (@RO UB ,register ,offset)))
+ (else
+ (INST-EA (@RO UW ,register ,offset)))))
+
+(define-integrable (pseudo-register-offset register)
+ (+ (+ (* 16 4) (* 80 4))
+ (* 3 (register-renumber register))))
+
+(define-integrable (pseudo->machine-register source target)
+ (memory->machine-register (pseudo-register-home source) target))
+
+(define-integrable (machine->pseudo-register source target)
+ (machine-register->memory source (pseudo-register-home target)))
+
+(define-integrable (floreg->sti reg)
+ (- reg fr0))
+
+(define-integrable (general-register? register)
+ (< register fr0))
+
+(define-integrable (float-register? register)
+ (<= fr0 register fr7))
+\f
+;;;; Utilities for the rules
+
+(define (require-register! machine-reg)
+ (flush-register! machine-reg)
+ (need-register! machine-reg))
+
+(define-integrable (flush-register! machine-reg)
+ (prefix-instructions! (clear-registers! machine-reg)))
+
+(define (rtl-target:=machine-register! rtl-reg machine-reg)
+ (if (machine-register? rtl-reg)
+ (begin
+ (require-register! machine-reg)
+ (if (not (= rtl-reg machine-reg))
+ (suffix-instructions!
+ (register->register-transfer machine-reg rtl-reg))))
+ (begin
+ (delete-register! rtl-reg)
+ (flush-register! machine-reg)
+ (add-pseudo-register-alias! rtl-reg machine-reg))))
+
+(define (object->machine-register! object mreg)
+ ;; This funny ordering allows load-constant to use a pc value in mreg!
+ (let ((code (load-constant (INST-EA (R ,mreg)) object)))
+ (require-register! mreg)
+ code))
+
+(define (assign-register->register target source)
+ (move-to-alias-register! source (register-type target) target)
+ (LAP))
+
+(define (convert-object/constant->register target constant conversion)
+ (delete-dead-registers!)
+ (let ((target (target-register-reference target)))
+ (if (non-pointer-object? constant)
+ ;; Is this correct if conversion is object->address ?
+ (load-non-pointer target 0 (careful-object-datum constant))
+ (LAP ,@(load-constant target constant)
+ ,@(conversion target)))))
+
+(define (non-pointer->literal object)
+ (make-non-pointer-literal (object-type object)
+ (careful-object-datum object)))
+
+(define (load-immediate target value)
+ (if (zero? value)
+ (LAP (XOR W ,target ,target))
+ (LAP (MOV W ,target (& ,value)))))
+
+(define (load-non-pointer target type datum)
+ (let ((immediate-value (make-non-pointer-literal type datum)))
+ (if (zero? immediate-value)
+ (LAP (XOR W ,target ,target))
+ (LAP (MOV W ,target (&U ,immediate-value))))))
+
+(define (load-constant target obj)
+ (if (non-pointer-object? obj)
+ (load-non-pointer target (object-type obj) (careful-object-datum obj))
+ (load-pc-relative target (constant->label obj))))
+
+(define (load-pc-relative target label-expr)
+ (with-pc
+ (lambda (pc-label pc-register)
+ (LAP (MOV W ,target (@RO W ,pc-register (- ,label-expr ,pc-label)))))))
+
+(define (load-pc-relative-address target label-expr)
+ (with-pc
+ (lambda (pc-label pc-register)
+ (LAP (LEA ,target (@RO W ,pc-register (- ,label-expr ,pc-label)))))))
+\f
+(define (with-pc recvr)
+ (with-values (lambda () (get-cached-label))
+ (lambda (label reg)
+ (if label
+ (recvr label reg)
+ (let ((temporary (allocate-temporary-register! 'GENERAL)))
+ (pc->reg temporary
+ (lambda (label prefix)
+ (cache-label! label temporary)
+ (LAP ,@prefix
+ ,@(recvr label temporary)))))))))
+
+(define (pc->reg reg recvr)
+ (let ((label (generate-label 'GET-PC)))
+ (recvr label
+ (LAP (CALL (@PCR ,label))
+ (LABEL ,label)
+ (POP ,(register-reference reg))))))
+
+(define-integrable (get-cached-label)
+ (register-map-label *register-map* 'GENERAL))
+
+(define-integrable (cache-label! label temporary)
+ (set! *register-map*
+ (set-machine-register-label *register-map* temporary label))
+ unspecific)
+
+(define (compare/register*register reg1 reg2)
+ (cond ((register-alias reg1 'GENERAL)
+ =>
+ (lambda (alias)
+ (LAP (CMP W ,(register-reference alias) ,(any-reference reg2)))))
+ ((register-alias reg2 'GENERAL)
+ =>
+ (lambda (alias)
+ (LAP (CMP W ,(any-reference reg1) ,(register-reference alias)))))
+ (else
+ (LAP (CMP W ,(source-register-reference reg1)
+ ,(any-reference reg2))))))
+\f
+(define (target-register target)
+ (delete-dead-registers!)
+ (or (register-alias target 'GENERAL)
+ (allocate-alias-register! target 'GENERAL)))
+
+(define-integrable (target-register-reference target)
+ (register-reference (target-register target)))
+
+(define-integrable (temporary-register-reference)
+ (reference-temporary-register! 'GENERAL))
+
+(define (source-register source)
+ (or (register-alias source 'GENERAL)
+ (load-alias-register! source 'GENERAL)))
+
+(define-integrable (source-register-reference source)
+ (register-reference (source-register source)))
+
+(define-integrable (any-reference rtl-reg)
+ (standard-register-reference rtl-reg 'GENERAL true))
+
+(define (standard-move-to-temporary! source)
+ (register-reference (move-to-temporary-register! source 'GENERAL)))
+
+(define (standard-move-to-target! source target)
+ (register-reference (move-to-alias-register! source 'GENERAL target)))
+
+(define (indirect-reference! rtl-reg offset)
+ (offset-reference (allocate-indirection-register! rtl-reg)
+ offset))
+
+(define (indirect-byte-reference! register offset)
+ (byte-offset-reference (allocate-indirection-register! register) offset))
+
+(define-integrable (allocate-indirection-register! register)
+ (load-alias-register! register 'GENERAL))
+\f
+(define (with-indexed-address base* index* scale b-offset protect recvr)
+ (let* ((base (allocate-indirection-register! base*))
+ (index (source-register index*))
+ (with-address-temp
+ (lambda (temp)
+ (let ((tref (register-reference temp))
+ (ea (indexed-ea-mode base index scale b-offset)))
+ (LAP (LEA ,tref ,ea)
+ ,@(object->address tref)
+ ,@(recvr (INST-EA (@R ,temp)))))))
+ (with-reused-temp
+ (lambda (temp)
+ (need-register! temp)
+ (with-address-temp temp)))
+ (fail-index
+ (lambda ()
+ (with-address-temp
+ (allocate-temporary-register! 'GENERAL))))
+ (fail-base
+ (lambda ()
+ (if (and protect (= index* protect))
+ (fail-index)
+ (reuse-pseudo-register-alias! index*
+ 'GENERAL
+ with-reused-temp
+ fail-index)))))
+ (if (and protect (= base* protect))
+ (fail-base)
+ (reuse-pseudo-register-alias! base*
+ 'GENERAL
+ with-reused-temp
+ fail-base))))
+
+(define (indexed-ea base index scale offset)
+ (indexed-ea-mode (allocate-indirection-register! base)
+ (source-register index)
+ scale
+ offset))
+
+(define (indexed-ea-mode base index scale offset)
+ (cond ((zero? offset)
+ (INST-EA (@RI ,base ,index ,scale)))
+ ((<= -128 offset 127)
+ (INST-EA (@ROI B ,base ,offset ,index ,scale)))
+ (else
+ (INST-EA (@ROI W ,base ,offset ,index ,scale)))))
+\f
+(define (rtl:simple-offset? expression)
+ (and (rtl:offset? expression)
+ (let ((base (rtl:offset-base expression))
+ (offset (rtl:offset-offset expression)))
+ (if (rtl:register? base)
+ (or (rtl:machine-constant? offset)
+ (rtl:register? offset))
+ (and (rtl:offset-address? base)
+ (rtl:machine-constant? offset)
+ (rtl:register? (rtl:offset-address-base base))
+ (rtl:register? (rtl:offset-address-offset base)))))
+ expression))
+
+(define (offset->reference! offset)
+ ;; OFFSET must be a simple offset
+ (let ((base (rtl:offset-base offset))
+ (offset (rtl:offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (indexed-ea (rtl:register-number (rtl:offset-address-base base))
+ (rtl:register-number (rtl:offset-address-offset base))
+ 4
+ (* 4 (rtl:machine-constant-value offset))))
+ ((rtl:machine-constant? offset)
+ (indirect-reference! (rtl:register-number base)
+ (rtl:machine-constant-value offset)))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 4
+ 0)))))
+
+(define (rtl:simple-byte-offset? expression)
+ (and (rtl:byte-offset? expression)
+ (let ((base (rtl:byte-offset-base expression))
+ (offset (rtl:byte-offset-offset expression)))
+ (if (rtl:register? base)
+ (or (rtl:machine-constant? offset)
+ (rtl:register? offset))
+ (and (rtl:byte-offset-address? base)
+ (rtl:machine-constant? offset)
+ (rtl:register? (rtl:byte-offset-address-base base))
+ (rtl:register? (rtl:byte-offset-address-offset base)))))
+ expression))
+
+(define (rtl:detagged-index? base offset)
+ (let ((o-ok? (and (rtl:object->datum? offset)
+ (rtl:register? (rtl:object->datum-expression offset)))))
+ (if (and (rtl:object->address? base)
+ (rtl:register? (rtl:object->address-expression base)))
+ (or o-ok? (rtl:register? offset))
+ (and o-ok? (rtl:register? base)))))
+\f
+(define (byte-offset->reference! offset)
+ ;; OFFSET must be a simple byte offset
+ (let ((base (rtl:byte-offset-base offset))
+ (offset (rtl:byte-offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (indexed-ea (rtl:register-number
+ (rtl:byte-offset-address-base base))
+ (rtl:register-number
+ (rtl:byte-offset-address-offset base))
+ 1
+ (rtl:machine-constant-value offset)))
+ ((rtl:machine-constant? offset)
+ (indirect-byte-reference! (rtl:register-number base)
+ (rtl:machine-constant-value offset)))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 1
+ 0)))))
+
+(define (rtl:simple-float-offset? expression)
+ (and (rtl:float-offset? expression)
+ (let ((base (rtl:float-offset-base expression))
+ (offset (rtl:float-offset-offset expression)))
+ (and (or (rtl:machine-constant? offset)
+ (rtl:register? offset))
+ (or (rtl:register? base)
+ (and (rtl:offset-address? base)
+ (rtl:register? (rtl:offset-address-base base))
+ (rtl:machine-constant?
+ (rtl:offset-address-offset base))))))
+ expression))
+
+(define (float-offset->reference! offset)
+ ;; OFFSET must be a simple float offset
+ (let ((base (rtl:float-offset-base offset))
+ (offset (rtl:float-offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (let ((base*
+ (rtl:register-number (rtl:offset-address-base base)))
+ (w-offset
+ (rtl:machine-constant-value
+ (rtl:offset-address-offset base))))
+ (if (rtl:machine-constant? offset)
+ (indirect-reference!
+ base*
+ (+ (* 2 (rtl:machine-constant-value offset))
+ w-offset))
+ (indexed-ea base*
+ (rtl:register-number offset)
+ 8
+ (* 4 w-offset)))))
+ ((rtl:machine-constant? offset)
+ (indirect-reference! (rtl:register-number base)
+ (* 2 (rtl:machine-constant-value offset))))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 8
+ 0)))))
+\f
+(define (object->type target)
+ (LAP (SHR W ,target (& ,scheme-datum-width))))
+
+(define (object->datum target)
+ (LAP (AND W ,target (R ,regnum:datum-mask))))
+
+(define (object->address target)
+ (declare (integrate-operator object->datum))
+ (object->datum target))
+
+(define (interpreter-call-argument? expression)
+ (or (rtl:register? expression)
+ (and (rtl:cons-pointer? expression)
+ (rtl:machine-constant? (rtl:cons-pointer-type expression))
+ (rtl:machine-constant? (rtl:cons-pointer-datum expression)))
+ (rtl:simple-offset? expression)))
+
+(define (interpreter-call-argument->machine-register! expression register)
+ (let ((target (register-reference register)))
+ (case (car expression)
+ ((REGISTER)
+ (load-machine-register! (rtl:register-number expression) register))
+ ((CONS-POINTER)
+ (LAP ,@(clear-registers! register)
+ ,@(load-non-pointer (rtl:machine-constant-value
+ (rtl:cons-pointer-type expression))
+ (rtl:machine-constant-value
+ (rtl:cons-pointer-datum expression))
+ target)))
+ ((OFFSET)
+ (let ((source-reference (offset->reference! expression)))
+ (LAP ,@(clear-registers! register)
+ (MOV W ,target ,source-reference))))
+ (else
+ (error "Unknown expression type" (car expression))))))
+\f
+;;;; Named registers, codes, and entries
+
+(define reg:compiled-memtop
+ (offset-reference regnum:regs-pointer
+ register-block/memtop-offset))
+
+(define reg:environment
+ (offset-reference regnum:regs-pointer
+ register-block/environment-offset))
+
+(define reg:dynamic-link
+ (offset-reference regnum:regs-pointer
+ register-block/dynamic-link-offset))
+
+(define reg:lexpr-primitive-arity
+ (offset-reference regnum:regs-pointer
+ register-block/lexpr-primitive-arity-offset))
+
+(define reg:utility-arg-4
+ (offset-reference regnum:regs-pointer
+ register-block/utility-arg4-offset))
+
+(define reg:stack-guard
+ (offset-reference regnum:regs-pointer
+ register-block/stack-guard-offset))
+
+
+(let-syntax ((define-codes
+ (macro (start . names)
+ (define (loop names index)
+ (if (null? names)
+ '()
+ (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 primitive-error
+ quotient remainder modulo))
+
+(define-integrable (invoke-hook entry)
+ (LAP (JMP ,entry)))
+
+(define-integrable (invoke-hook/call entry)
+ (LAP (CALL ,entry)))
+
+(define-integrable (invoke-interface code)
+ (LAP (MOV B (R ,eax) (& ,code))
+ ,@(invoke-hook entry:compiler-scheme-to-interface)))
+
+(define-integrable (invoke-interface/call code)
+ (LAP (MOV B (R ,eax) (& ,code))
+ ,@(invoke-hook/call entry:compiler-scheme-to-interface/call)))
+\f
+(let-syntax ((define-entries
+ (macro (start high . names)
+ (define (loop names index high)
+ (cond ((null? names)
+ '())
+ ((>= index high)
+ (warn "define-entries: Too many for byte offsets.")
+ (loop names index (+ high 32000)))
+ (else
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'ENTRY:COMPILER-
+ (car names))
+ (byte-offset-reference regnum:regs-pointer
+ ,index))
+ (loop (cdr names) (+ index 4) high)))))
+ `(BEGIN ,@(loop names start high)))))
+ (define-entries #x40 #x80 ; (* 16 4)
+ scheme-to-interface ; Main entry point (only one necessary)
+ scheme-to-interface/call ; Used by rules3&4, for convenience.
+ trampoline-to-interface ; Used by trampolines, for convenience.
+ interrupt-procedure
+ interrupt-continuation
+ interrupt-closure
+ interrupt-dlink
+ primitive-apply
+ primitive-lexpr-apply
+ assignment-trap
+ reference-trap
+ safe-reference-trap
+ link
+ error
+ primitive-error
+ short-primitive-apply)
+
+ (define-entries #x-80 0
+ &+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
+ quotient
+ remainder
+ modulo
+ shortcircuit-apply ; Used by rules3, for speed.
+ shortcircuit-apply-size-1 ; Small frames, save time and space.
+ shortcircuit-apply-size-2
+ shortcircuit-apply-size-3
+ shortcircuit-apply-size-4
+ shortcircuit-apply-size-5
+ shortcircuit-apply-size-6
+ shortcircuit-apply-size-7
+ shortcircuit-apply-size-8
+ interrupt-continuation-2))
+
+;; Operation tables
+
+(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 (lookup-arithmetic-method operator methods)
+ (cdr (or (assq operator (cdr methods))
+ (error "Unknown operator" operator))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/lapopt.scm,v 1.1 1995/01/10 20:53:00 adams Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Optimizer for Intel i386.
+
+(declare (usual-integrations))
+
+(define (optimize-linear-lap instructions)
+ instructions)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: make.scm,v 1.1 1995/01/10 20:53:03 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler: System Construction
+
+(declare (usual-integrations))
+
+(let* ((val ((load "base/make") "Intel i386"))
+ (env (->environment '(compiler))))
+ (set! (access compiler:generate-stack-checks? env) false)
+ (set! (access compiler:compress-top-level? env) true)
+ val)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pc-make.scm,v 1.1 1995/01/10 20:53:03 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler: System Construction
+
+(declare (usual-integrations))
+
+(begin
+ (load-option 'compress)
+ (load "machines/i386/make"))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/rgspcm.scm,v 1.1 1995/01/10 20:53:04 adams Exp $
+$MC68020-Header: /scheme/compiler/bobcat/RCS/rgspcm.scm,v 4.2 1991/05/06 23:17:03 jinx Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Generation: Special primitive combinations. Intel i386 version.
+;;; package: (compiler rtl-generator)
+
+(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?)
+(define-special-primitive/standard 'quotient)
+(define-special-primitive/standard 'remainder)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules1.scm,v 1.1 1995/01/10 20:53:04 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Data Transfers.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Register Assignments
+
+;;; 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)))
+ (assign-register->register target source))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (REGISTER (? index))))
+ (load-indexed-register target source index 4))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
+ (load-displaced-register target source (* 4 n)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (REGISTER (? index))))
+ (load-indexed-register target source index 1))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
+ (load-displaced-register target source n))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
+ (REGISTER (? index))))
+ (load-indexed-register target source index 8))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
+ (load-displaced-register target source (* 8 n)))
+
+(define-rule statement
+ ;; This is an intermediate rule -- not intended to produce code.
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
+ (load-displaced-register/typed target source type (* 4 n)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
+ (load-displaced-register/typed target source type n))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (object->type (standard-move-to-target! source target)))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (let ((temp (standard-move-to-temporary! type)))
+ (LAP (ROR W ,temp (&U ,scheme-type-width))
+ (OR W ,(standard-move-to-target! datum target) ,temp))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
+ (if (zero? type)
+ (assign-register->register target datum)
+ (let ((literal (make-non-pointer-literal type 0)))
+ (define (three-arg source)
+ (let ((target (target-register-reference target)))
+ (LAP (LEA ,target (@RO UW ,source ,literal)))))
+
+ (define (two-arg target)
+ (LAP (OR W ,target (&U ,literal))))
+
+ (let ((alias (register-alias datum 'GENERAL)))
+ (cond ((not alias)
+ (two-arg (standard-move-to-target! datum target)))
+ ((register-copy-if-available datum 'GENERAL target)
+ =>
+ (lambda (get-tgt)
+ (two-arg (get-tgt))))
+ (else
+ (three-arg alias)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+ (object->datum (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (object->address (standard-move-to-target! source target)))
+\f
+;;;; Loading Constants
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
+ (load-constant (target-register-reference target) source))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
+ (load-immediate (target-register-reference target) n))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (load-non-pointer (target-register-reference target) type datum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
+ (load-pc-relative-address
+ (target-register-reference target)
+ (rtl-procedure/external-label (label->object label))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
+ (load-pc-relative-address (target-register-reference target) label))
+
+(define-rule statement
+ ;; This is an intermediate rule -- not intended to produce code.
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:PROCEDURE (? label))))
+ (load-pc-relative-address/typed (target-register-reference target)
+ type
+ (rtl-procedure/external-label
+ (label->object label))))
+
+(define-rule statement
+ ;; This is an intermediate rule -- not intended to produce code.
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:CONTINUATION (? label))))
+ (load-pc-relative-address/typed (target-register-reference target)
+ type label))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+ (load-pc-relative (target-register-reference target)
+ (free-reference-label name)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
+ (load-pc-relative (target-register-reference target)
+ (free-assignment-label name)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
+ (convert-object/constant->register target constant object->datum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? constant))))
+ (convert-object/constant->register target constant object->address))
+\f
+;;;; Transfers from Memory
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:simple-offset?))
+ (let ((source (offset->reference! expression)))
+ (LAP (MOV W ,(target-register-reference target) ,source))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 4) 1))
+ (LAP (POP ,(target-register-reference target))))
+
+;;;; Transfers to Memory
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-offset?) (REGISTER (? r)))
+ (QUALIFIER (register-value-class=word? r))
+ (let ((source (source-register-reference r)))
+ (LAP (MOV W
+ ,(offset->reference! expression)
+ ,source))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-offset?) (CONSTANT (? value)))
+ (QUALIFIER (non-pointer-object? value))
+ (LAP (MOV W ,(offset->reference! expression)
+ (&U ,(non-pointer->literal value)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-offset?)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (LAP (MOV W ,(offset->reference! expression)
+ (&U ,(make-non-pointer-literal type datum)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-offset?)
+ (BYTE-OFFSET-ADDRESS (? expression)
+ (MACHINE-CONSTANT (? n))))
+ (if (zero? n)
+ (LAP)
+ (LAP (ADD W ,(offset->reference! expression) (& ,n)))))
+\f
+;;;; Consing
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 7) 1) (REGISTER (? r)))
+ (QUALIFIER (register-value-class=word? r))
+ (LAP (MOV W (@R 7) ,(source-register-reference r))
+ (ADD W (R 7) (& 4))))
+
+;;;; Pushes
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 4) -1) (REGISTER (? r)))
+ (QUALIFIER (register-value-class=word? r))
+ (LAP (PUSH ,(source-register-reference r))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 4) -1) (CONSTANT (? value)))
+ (QUALIFIER (non-pointer-object? value))
+ (LAP (PUSH W (&U ,(non-pointer->literal value)))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 4) -1)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (LAP (PUSH W (&U ,(make-non-pointer-literal type datum)))))
+\f
+;;;; CHAR->ASCII/BYTE-OFFSET
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (? expression rtl:simple-offset?)))
+ (load-char-into-register 0
+ (offset->reference! expression)
+ target))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (REGISTER (? source))))
+ (load-char-into-register 0
+ (source-register-reference source)
+ target))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:simple-byte-offset?))
+ (load-char-into-register 0
+ (byte-offset->reference! expression)
+ target))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (? expression rtl:simple-byte-offset?)))
+ (load-char-into-register type
+ (byte-offset->reference! expression)
+ target))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-byte-offset?)
+ (CHAR->ASCII (CONSTANT (? character))))
+ (LAP (MOV B
+ ,(byte-offset->reference! expression)
+ (& ,(char->signed-8-bit-immediate character)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-byte-offset?)
+ (REGISTER (? source)))
+ (let* ((source (source-register-reference source))
+ (target (byte-offset->reference! expression)))
+ (LAP (MOV B ,target ,source))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-byte-offset?)
+ (CHAR->ASCII (REGISTER (? source))))
+ (let ((source (source-register-reference source))
+ (target (byte-offset->reference! expression)))
+ (LAP (MOV B ,target ,source))))
+
+(define (char->signed-8-bit-immediate character)
+ (let ((ascii (char->ascii character)))
+ (if (< ascii 128) ascii (- ascii 256))))
+\f
+;;;; Utilities specific to rules1
+
+(define (load-displaced-register/internal target source n signed?)
+ (cond ((zero? n)
+ (assign-register->register target source))
+ ((and (= target source)
+ (= target esp))
+ (if signed?
+ (LAP (ADD W (R ,esp) (& ,n)))
+ (LAP (ADD W (R ,esp) (&U ,n)))))
+ (signed?
+ (let* ((source (indirect-byte-reference! source n))
+ (target (target-register-reference target)))
+ (LAP (LEA ,target ,source))))
+ (else
+ (let* ((source (indirect-unsigned-byte-reference! source n))
+ (target (target-register-reference target)))
+ (LAP (LEA ,target ,source))))))
+
+(define-integrable (load-displaced-register target source n)
+ (load-displaced-register/internal target source n true))
+
+(define-integrable (load-displaced-register/typed target source type n)
+ (load-displaced-register/internal target
+ source
+ (if (zero? type)
+ n
+ (+ (make-non-pointer-literal type 0)
+ n))
+ false))
+
+(define (load-indexed-register target source index scale)
+ (let* ((source (indexed-ea source index scale 0))
+ (target (target-register-reference target)))
+ (LAP (LEA ,target ,source))))
+
+(define (load-pc-relative-address/typed target type label)
+ (with-pc
+ (lambda (pc-label pc-register)
+ (LAP (LEA ,target (@RO UW
+ ,pc-register
+ (+ ,(make-non-pointer-literal type 0)
+ (- ,label ,pc-label))))))))
+
+(define (load-char-into-register type source target)
+ (let ((target (target-register-reference target)))
+ (cond ((zero? type)
+ ;; No faster, but smaller
+ (LAP (MOVZX B ,target ,source)))
+ (else
+ (LAP ,@(load-non-pointer target type 0)
+ (MOV B ,target ,source))))))
+
+(define (indirect-unsigned-byte-reference! register offset)
+ (byte-unsigned-offset-reference (allocate-indirection-register! register)
+ offset))
+\f
+;;;; Improved vector and string references
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (? expression rtl:detagged-offset?))
+ (with-detagged-vector-location expression false
+ (lambda (temp)
+ (LAP (MOV W ,(target-register-reference target) ,temp)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-offset?)
+ (REGISTER (? source)))
+ (QUALIFIER (register-value-class=word? source))
+ (with-detagged-vector-location expression source
+ (lambda (temp)
+ (LAP (MOV W ,temp ,(source-register-reference source))))))
+
+(define (with-detagged-vector-location rtl-expression protect recvr)
+ (with-decoded-detagged-offset rtl-expression
+ (lambda (base index offset)
+ (with-indexed-address base index 4 (* 4 offset) protect recvr))))
+
+(define (rtl:detagged-offset? expression)
+ (and (rtl:offset? expression)
+ (rtl:machine-constant? (rtl:offset-offset expression))
+ (let ((base (rtl:offset-base expression)))
+ (and (rtl:offset-address? base)
+ (rtl:detagged-index? (rtl:offset-address-base base)
+ (rtl:offset-address-offset base))))
+ expression))
+
+(define (with-decoded-detagged-offset expression recvr)
+ (let ((base (rtl:offset-base expression)))
+ (let ((base* (rtl:offset-address-base base))
+ (index (rtl:offset-address-offset base)))
+ (recvr (rtl:register-number (if (rtl:register? base*)
+ base*
+ (rtl:object->address-expression base*)))
+ (rtl:register-number (if (rtl:register? index)
+ index
+ (rtl:object->datum-expression index)))
+ (rtl:machine-constant-value (rtl:offset-offset expression))))))
+\f
+;;;; Improved string references
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:detagged-byte-offset?))
+ (load-char-indexed/detag 0 target expression))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (? expression rtl:detagged-byte-offset?)))
+ (load-char-indexed/detag type target expression))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-byte-offset?)
+ (REGISTER (? source)))
+ (store-char-indexed/detag expression
+ source
+ (source-register-reference source)))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-byte-offset?)
+ (CHAR->ASCII (REGISTER (? source))))
+ (store-char-indexed/detag expression
+ source
+ (source-register-reference source)))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-byte-offset?)
+ (CHAR->ASCII (CONSTANT (? character))))
+ (store-char-indexed/detag expression
+ false
+ (INST-EA (& ,(char->signed-8-bit-immediate
+ character)))))
+
+(define (load-char-indexed/detag tag target rtl-source-expression)
+ (with-detagged-string-location rtl-source-expression false
+ (lambda (temp)
+ (load-char-into-register tag temp target))))
+
+(define (store-char-indexed/detag rtl-target-expression protect source)
+ (with-detagged-string-location rtl-target-expression protect
+ (lambda (temp)
+ (LAP (MOV B ,temp ,source)))))
+
+(define (with-detagged-string-location rtl-expression protect recvr)
+ (with-decoded-detagged-byte-offset rtl-expression
+ (lambda (base index offset)
+ (with-indexed-address base index 1 offset protect recvr))))
+
+(define (rtl:detagged-byte-offset? expression)
+ (and (rtl:byte-offset? expression)
+ (rtl:machine-constant? (rtl:byte-offset-offset expression))
+ (let ((base (rtl:byte-offset-base expression)))
+ (and (rtl:byte-offset-address? base)
+ (rtl:detagged-index? (rtl:byte-offset-address-base base)
+ (rtl:byte-offset-address-offset base))))
+ expression))
+
+(define (with-decoded-detagged-byte-offset expression recvr)
+ (let ((base (rtl:byte-offset-base expression)))
+ (let ((base* (rtl:byte-offset-address-base base))
+ (index (rtl:byte-offset-address-offset base)))
+ (recvr (rtl:register-number (if (rtl:register? base*)
+ base*
+ (rtl:object->address-expression base*)))
+ (rtl:register-number (if (rtl:register? index)
+ index
+ (rtl:object->datum-expression index)))
+ (rtl:machine-constant-value
+ (rtl:byte-offset-offset expression))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules2.scm,v 1.1 1995/01/10 20:53:05 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Predicates
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define (set-equal-branches!)
+ (set-current-branches! (lambda (label)
+ (LAP (JE (@PCR ,label))))
+ (lambda (label)
+ (LAP (JNE (@PCR ,label))))))
+
+(define-rule predicate
+ (TYPE-TEST (REGISTER (? register)) (? type))
+ (set-equal-branches!)
+ (LAP (CMP B ,(reference-alias-register! register 'GENERAL) (&U ,type))))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
+ (set-equal-branches!)
+ (compare/register*register register-1 register-2))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register)) (? expression rtl:simple-offset?))
+ (set-equal-branches!)
+ (LAP (CMP W ,(source-register-reference register)
+ ,(offset->reference! expression))))
+
+(define-rule predicate
+ (EQ-TEST (? expression rtl:simple-offset?) (REGISTER (? register)))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ ,(source-register-reference register))))
+
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
+ (QUALIFIER (non-pointer-object? constant))
+ (set-equal-branches!)
+ (LAP (CMP W ,(any-reference register)
+ (&U ,(non-pointer->literal constant)))))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
+ (QUALIFIER (non-pointer-object? constant))
+ (set-equal-branches!)
+ (LAP (CMP W ,(any-reference register)
+ (&U ,(non-pointer->literal constant)))))
+\f
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant)) (? expression rtl:simple-offset?))
+ (QUALIFIER (non-pointer-object? constant))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ (&U ,(non-pointer->literal constant)))))
+
+(define-rule predicate
+ (EQ-TEST (? expression rtl:simple-offset?) (CONSTANT (? constant)))
+ (QUALIFIER (non-pointer-object? constant))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ (&U ,(non-pointer->literal constant)))))
+
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant-1)) (CONSTANT (? constant-2)))
+ (let ((always-jump
+ (lambda (label)
+ (LAP (JMP (@PCR ,label)))))
+ (always-fall-through
+ (lambda (label)
+ label ; ignored
+ (LAP))))
+ (if (eq? constant-1 constant-2)
+ (set-current-branches! always-jump always-fall-through)
+ (set-current-branches! always-fall-through always-jump)))
+ (LAP))
+
+(define-rule predicate
+ (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (REGISTER (? register)))
+ (set-equal-branches!)
+ (LAP (CMP W ,(any-reference register)
+ (&U ,(make-non-pointer-literal type datum)))))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (set-equal-branches!)
+ (LAP (CMP W ,(any-reference register)
+ (&U ,(make-non-pointer-literal type datum)))))
+
+(define-rule predicate
+ (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (? expression rtl:simple-offset?))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ (&U ,(make-non-pointer-literal type datum)))))
+
+(define-rule predicate
+ (EQ-TEST (? expression rtl:simple-offset?)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ (&U ,(make-non-pointer-literal type datum)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules3.scm,v 1.1 1995/01/10 20:53:05 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Invocations
+
+(define-integrable (clear-continuation-type-code)
+ (LAP (AND W (@R ,regnum:stack-pointer) (R ,regnum:datum-mask))))
+
+(define-rule statement
+ (POP-RETURN)
+ (cond ((block-association 'POP-RETURN)
+ => current-bblock-continue!)
+ (else
+ (let ((bblock
+ (make-new-sblock
+ (let ((interrupt-label (generate-label 'INTERRUPT)))
+ (LAP (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop)
+ (JGE (@PCR ,interrupt-label))
+ ,@(clear-continuation-type-code)
+ (RET)
+ (LABEL ,interrupt-label)
+ ,@(invoke-hook
+ entry:compiler-interrupt-continuation-2))))))
+ (block-associate! 'POP-RETURN bblock)
+ (current-bblock-continue! bblock))))
+ (clear-map!))
+
+(define-rule statement
+ (INVOCATION:APPLY (? frame-size) (? continuation))
+ continuation
+ (LAP ,@(clear-map!)
+ (POP (R ,ecx))
+ #|
+ (MOV W (R ,edx) (& ,frame-size))
+ ,@(invoke-interface code:compiler-apply)
+ |#
+ ,@(case frame-size
+ ((1) (invoke-hook entry:compiler-shortcircuit-apply-size-1))
+ ((2) (invoke-hook entry:compiler-shortcircuit-apply-size-2))
+ ((3) (invoke-hook entry:compiler-shortcircuit-apply-size-3))
+ ((4) (invoke-hook entry:compiler-shortcircuit-apply-size-4))
+ ((5) (invoke-hook entry:compiler-shortcircuit-apply-size-5))
+ ((6) (invoke-hook entry:compiler-shortcircuit-apply-size-6))
+ ((7) (invoke-hook entry:compiler-shortcircuit-apply-size-7))
+ ((8) (invoke-hook entry:compiler-shortcircuit-apply-size-8))
+ (else
+ (LAP (MOV W (R ,edx) (& ,frame-size))
+ ,@(invoke-hook entry:compiler-shortcircuit-apply))))))
+
+(define-rule statement
+ (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+ frame-size continuation
+ (LAP ,@(clear-map!)
+ (JMP (@PCR ,label))))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
+ frame-size continuation
+ ;; It expects the procedure at the top of the stack
+ (LAP ,@(clear-map!)
+ ,@(clear-continuation-type-code)
+ (RET)))
+
+(define-rule statement
+ (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
+ continuation
+ (with-pc
+ (lambda (pc-label pc-register)
+ (LAP ,@(clear-map!)
+ (LEA (R ,ecx) (@RO W ,pc-register (- ,label ,pc-label)))
+ (MOV W (R ,edx) (& ,number-pushed))
+ ,@(invoke-interface code:compiler-lexpr-apply)))))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
+ continuation
+ ;; It expects the procedure at the top of the stack
+ (LAP ,@(clear-map!)
+ ,@(clear-continuation-type-code)
+ (POP (R ,ecx))
+ (MOV W (R ,edx) (& ,number-pushed))
+ ,@(invoke-interface code:compiler-lexpr-apply)))
+
+(define-rule statement
+ (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
+ continuation
+ (LAP ,@(clear-map!)
+ (JMP (@PCRO ,(free-uuo-link-label name frame-size) 3))))
+\f
+(define-rule statement
+ (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
+ continuation
+ (LAP ,@(clear-map!)
+ (JMP (@PCRO ,(global-uuo-link-label name frame-size) 3))))
+
+(define-rule statement
+ (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
+ (QUALIFIER (interpreter-call-argument? extension))
+ continuation
+ (let* ((set-extension
+ (interpreter-call-argument->machine-register! extension ecx))
+ (set-address
+ (begin (require-register! edx)
+ (load-pc-relative-address (INST-EA (R ,edx))
+ *block-label*))))
+
+ (delete-dead-registers!)
+ (LAP ,@set-extension
+ ,@set-address
+ ,@(clear-map!)
+ (MOV W (R ,ebx) (& ,frame-size))
+ ,@(invoke-interface code:compiler-cache-reference-apply))))
+
+(define-rule statement
+ (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ continuation
+ (let* ((set-environment
+ (interpreter-call-argument->machine-register! environment ecx))
+ (set-name (object->machine-register! name edx)))
+ (delete-dead-registers!)
+ (LAP ,@set-environment
+ ,@set-name
+ ,@(clear-map!)
+ (MOV W (R ,ebx) (& ,frame-size))
+ ,@(invoke-interface code:compiler-lookup-apply))))
+\f
+(define-rule statement
+ (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
+ continuation ; ignored
+ (let-syntax ((invoke
+ #|
+ (macro (code entry)
+ entry ; ignored (for now)
+ `(invoke-interface ,code))
+ |#
+ (macro (code entry)
+ code ; ignored
+ `(invoke-hook ,entry))))
+
+ (if (eq? primitive compiled-error-procedure)
+ (LAP ,@(clear-map!)
+ (MOV W (R ,ecx) (& ,frame-size))
+ ,@(invoke code:compiler-error entry:compiler-error))
+ (let ((arity (primitive-procedure-arity primitive)))
+ (cond ((not (negative? arity))
+ (with-values (lambda () (get-cached-label))
+ (lambda (pc-label pc-reg)
+ pc-reg ; ignored
+ (if pc-label
+ (let ((get-code
+ (object->machine-register! primitive ecx)))
+ (LAP ,@get-code
+ ,@(clear-map!)
+ ,@(invoke code:compiler-primitive-apply
+ entry:compiler-primitive-apply)))
+ (let ((prim-label (constant->label primitive))
+ (offset-label (generate-label 'PRIMOFF)))
+ (LAP ,@(clear-map!)
+ ,@(invoke-hook/call
+ entry:compiler-short-primitive-apply)
+ (LABEL ,offset-label)
+ (LONG S (- ,prim-label ,offset-label))))))))
+ ((= arity -1)
+ (let ((get-code (object->machine-register! primitive ecx)))
+ (LAP ,@get-code
+ ,@(clear-map!)
+ (MOV W ,reg:lexpr-primitive-arity
+ (& ,(-1+ frame-size)))
+ ,@(invoke code:compiler-primitive-lexpr-apply
+ entry:compiler-primitive-lexpr-apply))))
+ (else
+ ;; Unknown primitive arity. Go through apply.
+ (let ((get-code (object->machine-register! primitive ecx)))
+ (LAP ,@get-code
+ ,@(clear-map!)
+ (MOV W (R ,edx) (& ,frame-size))
+ ,@(invoke-interface code:compiler-apply)))))))))
+\f
+(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
+ (special-primitive-invocation
+ ,(symbol-append 'CODE:COMPILER- name)))))
+
+ (define-optimized-primitive-invocation
+ (macro (name)
+ `(define-rule statement
+ (INVOCATION:SPECIAL-PRIMITIVE
+ (? frame-size)
+ (? continuation)
+ ,(make-primitive-procedure name true))
+ frame-size continuation
+ (optimized-primitive-invocation
+ ,(symbol-append 'ENTRY:COMPILER- name))))))
+
+ (let-syntax ((define-primitive-invocation
+ (macro (name)
+ #|
+ `(define-special-primitive-invocation ,name)
+ |#
+ `(define-optimized-primitive-invocation ,name))))
+
+ (define-primitive-invocation &+)
+ (define-primitive-invocation &-)
+ (define-primitive-invocation &*)
+ (define-primitive-invocation &/)
+ (define-primitive-invocation &=)
+ (define-primitive-invocation &<)
+ (define-primitive-invocation &>)
+ (define-primitive-invocation 1+)
+ (define-primitive-invocation -1+)
+ (define-primitive-invocation zero?)
+ (define-primitive-invocation positive?)
+ (define-primitive-invocation negative?)
+ (define-primitive-invocation quotient)
+ (define-primitive-invocation remainder)))
+
+(define (special-primitive-invocation code)
+ (LAP ,@(clear-map!)
+ ,@(invoke-interface code)))
+
+(define (optimized-primitive-invocation entry)
+ (LAP ,@(clear-map!)
+ ,@(invoke-hook entry)))
+
+;;; Invocation Prefixes
+
+(define-rule statement
+ (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 4))
+ (LAP))
+
+(define-rule statement
+ (INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 4) (? any))
+ any ; ignored
+ (LAP))
+\f
+(define-rule statement
+ (INVOCATION-PREFIX:MOVE-FRAME-UP
+ (? frame-size)
+ (OFFSET-ADDRESS (REGISTER 4)
+ (MACHINE-CONSTANT (? offset))))
+ (QUALIFIER (or (zero? (- offset frame-size)) (< frame-size 3)))
+ (let ((how-far (- offset frame-size)))
+ (cond ((zero? how-far)
+ (LAP))
+ ((zero? frame-size)
+ (LAP (ADD W (R 4) (& ,(* 4 how-far)))))
+ ((= frame-size 1)
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV W ,temp (@R 4))
+ (ADD W (R 4) (& ,(* 4 offset)))
+ (PUSH W ,temp))))
+ ((= frame-size 2)
+ (let ((temp1 (temporary-register-reference))
+ (temp2 (temporary-register-reference)))
+ (LAP (MOV W ,temp2 (@RO B 4 4))
+ (MOV W ,temp1 (@R 4))
+ (ADD W (R 4) (& ,(* 4 offset)))
+ (PUSH W ,temp2)
+ (PUSH W ,temp1))))
+ (else
+ (error "INVOCATION-PREFIX:MOVE-FRAME-UP: Incorrectly invoked!")))))
+
+(define-rule statement
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? reg)))
+ (generate/move-frame-up* frame-size
+ (move-to-temporary-register! reg 'GENERAL)
+ temporary-register-reference))
+
+(define-rule statement
+ (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
+ (REGISTER (? reg-1))
+ (REGISTER (? reg-2)))
+ (QUALIFIER (not (= reg-1 4)))
+ (let* ((label (generate-label 'DYN-CHOICE))
+ (temp1 (move-to-temporary-register! reg-1 'GENERAL))
+ (temp2 (standard-move-to-temporary! reg-2)))
+ (LAP (CMP W (R ,temp1) ,temp2)
+ (JLE (@PCR ,label))
+ (MOV W (R ,temp1) ,temp2)
+ (LABEL ,label)
+ ,@(generate/move-frame-up* frame-size temp1 (lambda () temp2)))))
+
+(define (generate/move-frame-up* frame-size reg get-temp)
+ (if (zero? frame-size)
+ (LAP (MOV W (R 4) (R ,reg)))
+ (let ((temp (get-temp))
+ (ctr (allocate-temporary-register! 'GENERAL))
+ (label (generate-label 'MOVE-LOOP)))
+ (LAP (LEA (R ,reg)
+ ,(byte-offset-reference reg (* -4 frame-size)))
+ (MOV W (R ,ctr) (& ,(-1+ frame-size)))
+ (LABEL ,label)
+ (MOV W ,temp (@RI 4 ,ctr 4))
+ (MOV W (@RI ,reg ,ctr 4) ,temp)
+ (DEC W (R ,ctr))
+ (JGE (@PCR ,label))
+ (MOV W (R 4) (R ,reg))))))
+\f
+;;;; External Labels
+
+;;; Entry point types
+
+(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 internal-entry-code-word
+ (make-code-word #xff #xfe))
+
+(define internal-continuation-code-word
+ (make-code-word #xff #xfc))
+
+(define (frame-size->code-word offset default)
+ (cond ((not offset)
+ default)
+ ((< 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))))
+
+(define (continuation-code-word label)
+ (frame-size->code-word
+ (if label
+ (rtl-continuation/next-continuation-offset (label->object label))
+ 0)
+ internal-continuation-code-word))
+
+(define (internal-procedure-code-word rtl-proc)
+ (frame-size->code-word
+ (rtl-procedure/next-continuation-offset rtl-proc)
+ internal-entry-code-word))
+\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.
+;;;
+;;; The only exception is the dynamic link register, handled
+;;; specially. Procedures that require a dynamic link use a different
+;;; interrupt handler that saves and restores the dynamic link
+;;; register.
+
+(define (interrupt-check procedure-label interrupt-label)
+ ;; This always does interrupt checks in line.
+ (LAP (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop)
+ (JGE (@PCR ,interrupt-label))
+ ,@(if (let ((object (label->object procedure-label)))
+ (and (rtl-procedure? object)
+ (not (rtl-procedure/stack-leaf? object))
+ compiler:generate-stack-checks?))
+ (LAP (CMP W (R ,regnum:stack-pointer) ,reg:stack-guard)
+ (JL (@PCR ,interrupt-label)))
+ (LAP))))
+
+(define (simple-procedure-header code-word label entry)
+ (let ((gc-label (generate-label)))
+ (LAP (LABEL ,gc-label)
+ ,@(invoke-hook/call entry)
+ ,@(make-external-label code-word label)
+ ,@(interrupt-check label gc-label))))
+
+(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
+ entry:compiler-interrupt-continuation)
+ |#
+ (make-external-label (continuation-code-word internal-label)
+ internal-label))
+
+(define-rule statement
+ (IC-PROCEDURE-HEADER (? internal-label))
+ (let ((procedure (label->object internal-label)))
+ (let ((external-label (rtl-procedure/external-label procedure))
+ (gc-label (generate-label)))
+ (LAP (ENTRY-POINT ,external-label)
+ (EQUATE ,external-label ,internal-label)
+ (LABEL ,gc-label)
+ ,@(invoke-interface/call code:compiler-interrupt-ic-procedure)
+ ,@(make-external-label expression-code-word internal-label)
+ ,@(interrupt-check internal-label gc-label)))))
+
+(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)
+ ,@(simple-procedure-header (internal-procedure-code-word rtl-proc)
+ internal-label
+ (if (rtl-procedure/dynamic-link? rtl-proc)
+ entry:compiler-interrupt-dlink
+ entry:compiler-interrupt-procedure)))))
+
+(define-rule statement
+ (PROCEDURE-HEADER (? internal-label) (? min) (? max))
+ (LAP (EQUATE ,(rtl-procedure/external-label
+ (label->object internal-label))
+ ,internal-label)
+ ,@(simple-procedure-header (make-procedure-code-word min max)
+ internal-label
+ entry:compiler-interrupt-procedure)))
+\f
+;;;; Closures:
+
+;; Since i386 instructions are pc-relative, the GC can't relocate them unless
+;; there is a way to find where the closure was in old space before being
+;; transported. The first entry point (tagged as an object) is always
+;; the last component of closures with any entry points.
+
+(define (generate/cons-closure target procedure-label min max size)
+ (let* ((mtarget (target-register target))
+ (target (register-reference mtarget))
+ (temp (temporary-register-reference)))
+ (LAP ,@(load-pc-relative-address
+ temp
+ `(- ,(rtl-procedure/external-label (label->object procedure-label))
+ 5))
+ (MOV W (@R ,regnum:free-pointer)
+ (&U ,(make-non-pointer-literal (ucode-type manifest-closure)
+ (+ 4 size))))
+ (MOV W (@RO B ,regnum:free-pointer 4)
+ (&U ,(make-closure-code-longword min max 8)))
+ (LEA ,target (@RO B ,regnum:free-pointer 8))
+ ;; (CALL (@PCR <entry>))
+ (MOV B (@RO B ,regnum:free-pointer 8) (&U #xe8))
+ (SUB W ,temp ,target)
+ (MOV W (@RO B ,regnum:free-pointer 9) ,temp) ; displacement
+ (ADD W (R ,regnum:free-pointer) (& ,(* 4 (+ 5 size))))
+ (LEA ,temp (@RO UW
+ ,mtarget
+ ,(make-non-pointer-literal (ucode-type compiled-entry)
+ 0)))
+ (MOV W (@RO B ,regnum:free-pointer -4) ,temp))))
+
+(define (generate/cons-multiclosure target nentries size entries)
+ (let* ((mtarget (target-register target))
+ (target (register-reference mtarget))
+ (temp (temporary-register-reference)))
+ (with-pc
+ (lambda (pc-label pc-reg)
+ (define (generate-entries entries offset)
+ (let ((entry (car entries))
+ (rest (cdr entries)))
+ (LAP (MOV W (@RO B ,regnum:free-pointer -9)
+ (&U ,(make-closure-code-longword (cadr entry)
+ (caddr entry)
+ offset)))
+ (MOV B (@RO B ,regnum:free-pointer -5) (&U #xe8))
+ (LEA ,temp (@RO W
+ ,pc-reg
+ (- ,(rtl-procedure/external-label
+ (label->object (car entry)))
+ ,pc-label)))
+ (SUB W ,temp (R ,regnum:free-pointer))
+ (MOV W (@RO B ,regnum:free-pointer -4) ,temp)
+ ,@(if (null? rest)
+ (LAP)
+ (LAP (ADD W (R ,regnum:free-pointer) (& 10))
+ ,@(generate-entries rest (+ 10 offset)))))))
+
+ (LAP (MOV W (@R ,regnum:free-pointer)
+ (&U ,(make-non-pointer-literal
+ (ucode-type manifest-closure)
+ (+ size (quotient (* 5 (1+ nentries)) 2)))))
+ (MOV W (@RO B ,regnum:free-pointer 4)
+ (&U ,(make-closure-longword nentries 0)))
+ (LEA ,target (@RO B ,regnum:free-pointer 12))
+ (ADD W (R ,regnum:free-pointer) (& 17))
+ ,@(generate-entries entries 12)
+ (ADD W (R ,regnum:free-pointer)
+ (& ,(+ (* 4 size) (if (odd? nentries) 7 5))))
+ (LEA ,temp
+ (@RO UW
+ ,mtarget
+ ,(make-non-pointer-literal (ucode-type compiled-entry)
+ 0)))
+ (MOV W (@RO B ,regnum:free-pointer -4) ,temp))))))
+\f
+(define closure-share-names
+ '#(
+ closure-0-interrupt closure-1-interrupt closure-2-interrupt closure-3-interrupt
+ closure-4-interrupt closure-5-interrupt closure-6-interrupt closure-7-interrupt
+ ))
+
+(define (generate/closure-header internal-label nentries entry)
+ nentries ; ignored
+ (let* ((rtl-proc (label->object internal-label))
+ (external-label (rtl-procedure/external-label rtl-proc)))
+ (if (zero? nentries)
+ (LAP (EQUATE ,external-label ,internal-label)
+ ,@(simple-procedure-header
+ (internal-procedure-code-word rtl-proc)
+ internal-label
+ entry:compiler-interrupt-procedure))
+ (let ((prefix
+ (lambda (gc-label)
+ (LAP (LABEL ,gc-label)
+ ,@(if (zero? entry)
+ (LAP)
+ (LAP (ADD W (@R ,esp) (& ,(* 10 entry)))))
+ ,@(invoke-hook entry:compiler-interrupt-closure))))
+ (suffix
+ (lambda (gc-label)
+ (LAP ,@(make-external-label internal-entry-code-word
+ external-label)
+ (ADD W (@R ,esp)
+ (&U ,(generate/make-magic-closure-constant entry)))
+ (LABEL ,internal-label)
+ ,@(interrupt-check internal-label gc-label)))))
+ (if (>= entry (vector-length closure-share-names))
+ (let ((gc-label (generate-label)))
+ (LAP ,@(prefix gc-label)
+ ,@(suffix gc-label)))
+ (share-instruction-sequence!
+ (vector-ref closure-share-names entry)
+ suffix
+ (lambda (gc-label)
+ (LAP ,@(prefix gc-label)
+ ,@(suffix gc-label)))))))))
+
+(define (generate/make-magic-closure-constant entry)
+ (- (make-non-pointer-literal (ucode-type compiled-entry) 0)
+ (+ (* entry 10) 5)))
+
+(define (make-closure-longword code-word pc-offset)
+ (+ code-word (* #x20000 pc-offset)))
+
+(define (make-closure-code-longword frame/min frame/max pc-offset)
+ (make-closure-longword (make-procedure-code-word frame/min frame/max)
+ pc-offset))
+
+(define-rule statement
+ (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+ (generate/closure-header internal-label nentries entry))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+ (? min) (? max) (? size)))
+ (generate/cons-closure target procedure-label min max size))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+ (case nentries
+ ((0)
+ (let ((target (target-register-reference target)))
+ (LAP (MOV W ,target (R ,regnum:free-pointer))
+ (MOV W (@R ,regnum:free-pointer)
+ (&U ,(make-non-pointer-literal (ucode-type manifest-vector)
+ size)))
+ (ADD W (R ,regnum:free-pointer) (& ,(* 4 (1+ size)))))))
+ ((1)
+ (let ((entry (vector-ref entries 0)))
+ (generate/cons-closure target
+ (car entry) (cadr entry) (caddr entry)
+ size)))
+ (else
+ (generate/cons-multiclosure target nentries size
+ (vector->list entries)))))
+\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)
+ (pc->reg eax
+ (lambda (pc-label prefix)
+ (LAP ,@prefix
+ (MOV W (R ,ecx) ,reg:environment)
+ (MOV W (@RO W ,eax (- ,environment-label ,pc-label))
+ (R ,ecx))
+ (LEA (R ,edx) (@RO W ,eax (- ,*block-label* ,pc-label)))
+ (LEA (R ,ebx) (@RO W ,eax (- ,free-ref-label ,pc-label)))
+ (MOV W ,reg:utility-arg-4 (& ,n-sections))
+ #|
+ ,@(invoke-interface/call code:compiler-link)
+ |#
+ ,@(invoke-hook/call entry: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)
+ (pc->reg eax
+ (lambda (pc-label prefix)
+ (LAP ,@prefix
+ (MOV W (R ,edx) (@RO W ,eax (- ,code-block-label ,pc-label)))
+ (AND W (R ,edx) (R ,regnum:datum-mask))
+ (LEA (R ,ebx) (@RO W ,edx ,free-ref-offset))
+ (MOV W (R ,ecx) ,reg:environment)
+ (MOV W (@RO W ,edx ,environment-offset) (R ,ecx))
+ (MOV W ,reg:utility-arg-4 (& ,n-sections))
+ #|
+ ,@(invoke-interface/call code:compiler-link)
+ |#
+ ,@(invoke-hook/call entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))))
+\f
+(define (generate/remote-links n-blocks vector-label nsects)
+ (if (zero? n-blocks)
+ (LAP)
+ (let ((loop (generate-label))
+ (bytes (generate-label))
+ (end (generate-label)))
+ (LAP
+ ;; Push counter
+ (PUSH W (& 0))
+ (LABEL ,loop)
+ ,@(pc->reg
+ eax
+ (lambda (pc-label prefix)
+ (LAP ,@prefix
+ ;; Get index
+ (MOV W (R ,ecx) (@R ,esp))
+ ;; Get vector
+ (MOV W (R ,edx) (@RO W ,eax (- ,vector-label ,pc-label)))
+ ;; Get n-sections for this cc-block
+ (XOR W (R ,ebx) (R ,ebx))
+ (MOV B (R ,ebx) (@ROI B ,eax (- ,bytes ,pc-label) ,ecx 1))
+ ;; address of vector
+ (AND W (R ,edx) (R ,regnum:datum-mask))
+ ;; Store n-sections in arg
+ (MOV W ,reg:utility-arg-4 (R ,ebx))
+ ;; vector-ref -> cc block
+ (MOV W (R ,edx) (@ROI B ,edx 4 ,ecx 4))
+ ;; address of cc-block
+ (AND W (R ,edx) (R ,regnum:datum-mask))
+ ;; cc-block length
+ (MOV W (R ,ebx) (@R ,edx))
+ ;; Get environment
+ (MOV W (R ,ecx) ,reg:environment)
+ ;; Eliminate length tags
+ (AND W (R ,ebx) (R ,regnum:datum-mask))
+ ;; Store environment
+ (MOV W (@RI ,edx ,ebx 4) (R ,ecx))
+ ;; Get NMV header
+ (MOV W (R ,ecx) (@RO B ,edx 4))
+ ;; Eliminate NMV tag
+ (AND W (R ,ecx) (R ,regnum:datum-mask))
+ ;; Address of first free reference
+ (LEA (R ,ebx) (@ROI B ,edx 8 ,ecx 4))
+ ;; Invoke linker
+ ,@(invoke-hook/call entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))
+ ;; Increment counter and loop
+ (INC W (@R ,esp))
+ (CMP W (@R ,esp) (& ,n-blocks))
+ (JL (@PCR ,loop))
+ )))
+ (JMP (@PCR ,end))
+ (LABEL ,bytes)
+ ,@(let walk ((bytes (vector->list nsects)))
+ (if (null? bytes)
+ (LAP)
+ (LAP (BYTE U ,(car bytes))
+ ,@(walk (cdr bytes)))))
+ (LABEL ,end)
+ ;; Pop counter
+ (POP (R ,eax))))))
+\f
+(define (generate/constants-block constants references assignments
+ uuo-links global-links static-vars)
+ (let ((constant-info
+ (declare-constants 0 (transmogrifly uuo-links)
+ (declare-constants 1 references
+ (declare-constants 2 assignments
+ (declare-constants 3 (transmogrifly global-links)
+ (declare-constants false
+ (map (lambda (pair)
+ (cons false (cdr pair)))
+ static-vars)
+ (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)
+ (if (null? global-links) 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))))
+\f
+;; IMPORTANT:
+;; frame-size and uuo-label are switched (with respect to the 68k
+;; version) in order to preserve the arity in a constant position (the
+;; i386 is little-endian). The invocation rule for uuo-links has been
+;; changed to take the extra 2 bytes into account.
+;;
+;; Like closures, execute caches use pc-relative JMP instructions,
+;; which can only be relocated if the old address is available.
+;; Thus execute-cache blocks are extended by a single word that
+;; contains its own address.
+
+(define (transmogrifly uuos)
+ (define (do-rest uuos)
+ (define (inner name assoc)
+ (if (null? assoc)
+ (do-rest (cdr uuos))
+ (cons (cons (caar assoc) ; frame-size
+ (cdar assoc)) ; uuo-label
+ (cons (cons name ; variable name
+ (allocate-constant-label)) ; dummy label
+ (inner name (cdr assoc))))))
+
+ (if (null? uuos)
+ '()
+ (inner (caar uuos) (cdar uuos))))
+
+ (if (null? uuos)
+ '()
+ (cons (cons false (allocate-constant-label)) ; relocation address
+ (do-rest uuos))))
+\f
+;;; Local Variables: ***
+;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
+;;; End: ***
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules4.scm,v 1.1 1995/01/10 20:53:06 adams Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Interpreter Calls
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Variable cache trap handling.
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?))
+ (QUALIFIER (interpreter-call-argument? extension))
+ cont ; ignored
+ (let ((set-extension
+ (interpreter-call-argument->machine-register! extension edx)))
+ (LAP ,@set-extension
+ ,@(clear-map!)
+ #|
+ ,@(invoke-interface/call
+ (if safe?
+ code:compiler-safe-reference-trap
+ code:compiler-reference-trap))
+ |#
+ ,@(invoke-hook/call (if safe?
+ entry:compiler-safe-reference-trap
+ entry:compiler-reference-trap)))))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value))
+ (QUALIFIER (and (interpreter-call-argument? extension)
+ (interpreter-call-argument? value)))
+ cont ; ignored
+ (let* ((set-extension
+ (interpreter-call-argument->machine-register! extension edx))
+ (set-value (interpreter-call-argument->machine-register! value ebx)))
+ (LAP ,@set-extension
+ ,@set-value
+ ,@(clear-map!)
+ #|
+ ,@(invoke-interface/call code:compiler-assignment-trap)
+ |#
+ ,@(invoke-hook/call entry:compiler-assignment-trap))))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension))
+ (QUALIFIER (interpreter-call-argument? extension))
+ cont ; ignored
+ (let ((set-extension
+ (interpreter-call-argument->machine-register! extension edx)))
+ (LAP ,@set-extension
+ ,@(clear-map!)
+ ,@(invoke-interface/call code:compiler-unassigned?-trap))))
+\f
+;;;; Interpreter Calls
+
+;;; All the code that follows is obsolete. It hasn't been used in a while.
+;;; It is provided in case the relevant switches are turned off, but there
+;;; is no real reason to do this. Perhaps the switches should be removed.
+
+(define-rule statement
+ (INTERPRETER-CALL:ACCESS (? cont) (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ cont ; ignored
+ (lookup-call code:compiler-access environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?))
+ (QUALIFIER (interpreter-call-argument? environment))
+ cont ; ignored
+ (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
+ environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ cont ; ignored
+ (lookup-call code:compiler-unassigned? environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ cont ; ignored
+ (lookup-call code:compiler-unbound? environment name))
+
+(define (lookup-call code environment name)
+ (let ((set-environment
+ (interpreter-call-argument->machine-register! environment edx)))
+ (LAP ,@set-environment
+ ,@(clear-map (clear-map!))
+ ,@(load-constant (INST-EA (R ,ebx)) name)
+ ,@(invoke-interface/call code))))
+\f
+(define-rule statement
+ (INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value))
+ (QUALIFIER (and (interpreter-call-argument? environment)
+ (interpreter-call-argument? value)))
+ cont ; ignored
+ (assignment-call code:compiler-define environment name value))
+
+(define-rule statement
+ (INTERPRETER-CALL:SET! (? cont) (? environment) (? name) (? value))
+ (QUALIFIER (and (interpreter-call-argument? environment)
+ (interpreter-call-argument? value)))
+ cont ; ignored
+ (assignment-call code:compiler-set! environment name value))
+
+(define (assignment-call code environment name value)
+ (let* ((set-environment
+ (interpreter-call-argument->machine-register! environment edx))
+ (set-value (interpreter-call-argument->machine-register! value eax)))
+ (LAP ,@set-environment
+ ,@set-value
+ ,@(clear-map!)
+ (MOV W ,reg:utility-arg-4 (R ,eax))
+ ,@(load-constant (INST-EA (R ,ebx)) name)
+ ,@(invoke-interface/call code))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulfix.scm,v 1.1 1995/01/10 20:53:06 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Fixnum operations.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Making and examining fixnums
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
+ (address->fixnum (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+ (object->fixnum (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
+ (address->fixnum (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
+ (fixnum->object (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
+ (fixnum->address (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (CONSTANT (? constant)))))
+ (convert-object/constant->register target constant address->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (load-fixnum-constant constant (target-register-reference target)))
+\f
+;;;; Fixnum Operations
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
+ overflow? ; ignored
+ (fixnum-1-arg target source (fixnum-1-arg/operate operator)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operator)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ ((fixnum-2-args/operate operator) target source1 source2 overflow?))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operator)
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (? overflow?)))
+ (QUALIFIER (or (and (not (eq? operator 'FIXNUM-QUOTIENT))
+ (not (eq? operator 'FIXNUM-REMAINDER)))
+ (integer-power-of-2? (abs constant))))
+ (fixnum-2-args/register*constant operator target source constant overflow?))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operator)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER (fixnum-2-args/commutative? operator))
+ (fixnum-2-args/register*constant operator target source constant overflow?))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operator)
+ (OBJECT->FIXNUM (CONSTANT 0))
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER (not (fixnum-2-args/commutative? operator)))
+ overflow? ; ignored
+ (if (eq? operator 'MINUS-FIXNUM)
+ (fixnum-1-arg target source (fixnum-1-arg/operate 'FIXNUM-NEGATE))
+ (load-fixnum-constant 0 (target-register-reference target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (CONSTANT (? n)))
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ #f))
+ (fixnum-1-arg target source
+ (lambda (target)
+ (multiply-fixnum-constant target (* n fixnum-1) false))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ (OBJECT->FIXNUM (CONSTANT (? n)))
+ #f))
+ (fixnum-1-arg target source
+ (lambda (target)
+ (multiply-fixnum-constant target (* n fixnum-1) false))))
+\f
+;;;; Fixnum Predicates
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
+ (fixnum-branch! (fixnum-predicate/unary->binary predicate))
+ (LAP (CMP W ,(source-register-reference register) (& 0))))
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (OBJECT->FIXNUM (REGISTER (? register))))
+ (QUALIFIER (or (eq? predicate 'NEGATIVE-FIXNUM?)
+ (eq? predicate 'ZERO-FIXNUM?)))
+ (fixnum-branch! predicate)
+ (object->fixnum (standard-move-to-temporary! register)))
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (? expression rtl:simple-offset?))
+ (fixnum-branch! (fixnum-predicate/unary->binary predicate))
+ (LAP (CMP W ,(offset->reference! expression) (& 0))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? register-1))
+ (REGISTER (? register-2)))
+ (fixnum-branch! predicate)
+ (compare/register*register register-1 register-2))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? register))
+ (? expression rtl:simple-offset?))
+ (fixnum-branch! predicate)
+ (LAP (CMP W ,(source-register-reference register)
+ ,(offset->reference! expression))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (? expression rtl:simple-offset?)
+ (REGISTER (? register)))
+ (fixnum-branch! predicate)
+ (LAP (CMP W ,(offset->reference! expression)
+ ,(source-register-reference register))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? register))
+ (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (fixnum-branch! predicate)
+ (LAP (CMP W ,(source-register-reference register)
+ (& ,(* constant fixnum-1)))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (REGISTER (? register)))
+ (fixnum-branch! (commute-fixnum-predicate predicate))
+ (LAP (CMP W ,(source-register-reference register)
+ (& ,(* constant fixnum-1)))))
+\f
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (? expression rtl:simple-offset?)
+ (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (fixnum-branch! predicate)
+ (LAP (CMP W ,(offset->reference! expression)
+ (& ,(* constant fixnum-1)))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (? expression rtl:simple-offset?))
+ (fixnum-branch! (commute-fixnum-predicate predicate))
+ (LAP (CMP W ,(offset->reference! expression)
+ (& ,(* constant fixnum-1)))))
+
+;; This assumes that the immediately preceding instruction sets the
+;; condition code bits correctly.
+
+(define-rule predicate
+ (OVERFLOW-TEST)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (JO (@PCR ,label))))
+ (lambda (label)
+ (LAP (JNO (@PCR ,label)))))
+ (LAP))
+\f
+;;;; Utilities
+
+(define (object->fixnum target)
+ (LAP (SAL W ,target (& ,scheme-type-width))))
+
+;; Clearly wrong for the split typecodes:
+;;(define (fixnum->object target)
+;; (LAP (OR W ,target (& ,(ucode-type fixnum)))
+;; (ROR W ,target (& ,scheme-type-width))))
+
+(define (fixnum->object target)
+ (LAP (OR W ,target (& ,(ucode-type positive-fixnum)))
+ (ROR W ,target (& ,scheme-type-width))))
+
+(define (address->fixnum target)
+ (LAP (SAL W ,target (& ,scheme-type-width))))
+
+(define (fixnum->address target)
+ (LAP (SHR W ,target (& ,scheme-type-width))))
+
+(define-integrable fixnum-1 64) ; (expt 2 scheme-type-width) ***
+
+(define-integrable fixnum-bits-mask
+ (-1+ fixnum-1))
+
+(define (word->fixnum target)
+ (LAP (AND W ,target (& ,(fix:not fixnum-bits-mask)))))
+
+(define (integer-power-of-2? n)
+ (let loop ((power 1) (exponent 0))
+ (cond ((< n power) false)
+ ((= n power) exponent)
+ (else
+ (loop (* 2 power) (1+ exponent))))))
+
+(define (load-fixnum-constant constant target)
+ (if (zero? constant)
+ (LAP (XOR W ,target ,target))
+ (LAP (MOV W ,target (& ,(* constant fixnum-1))))))
+
+(define (add-fixnum-constant target constant overflow?)
+ (let ((value (* constant fixnum-1)))
+ (cond ((and (zero? value) (not overflow?))
+ (LAP))
+ ((and (not (fits-in-signed-byte? value))
+ (fits-in-signed-byte? (- value)))
+ (LAP (SUB W ,target (& ,(- value)))))
+ (else
+ (LAP (ADD W ,target (& ,value)))))))
+
+(define (multiply-fixnum-constant target constant overflow?)
+ (cond ((zero? constant)
+ (load-fixnum-constant 0 target))
+ ((= constant 1)
+ (if (not overflow?)
+ (LAP)
+ (add-fixnum-constant target 0 overflow?)))
+ ((= constant -1)
+ (LAP (NEG W ,target)))
+ ((and (not overflow?)
+ (integer-power-of-2? (abs constant)))
+ =>
+ (lambda (expt-of-2)
+ (if (negative? constant)
+ (LAP (SAL W ,target (& ,expt-of-2))
+ (NEG W ,target))
+ (LAP (SAL W ,target (& ,expt-of-2))))))
+ (else
+ ;; target must be a register!
+ (LAP (IMUL W ,target ,target (& ,constant))))))
+\f
+;;;; Operation tables
+
+(define fixnum-methods/1-arg
+ (list 'FIXNUM-METHODS/1-ARG))
+
+(define-integrable (fixnum-1-arg/operate operator)
+ (lookup-arithmetic-method operator fixnum-methods/1-arg))
+
+(define-integrable (fixnum-1-arg target source operation)
+ (operation (standard-move-to-target! source target)))
+
+(define fixnum-methods/2-args
+ (list 'FIXNUM-METHODS/2-ARGS))
+
+(define-integrable (fixnum-2-args/operate operator)
+ (lookup-arithmetic-method operator fixnum-methods/2-args))
+
+(define fixnum-methods/2-args-constant
+ (list 'FIXNUM-METHODS/2-ARGS-CONSTANT))
+
+(define-integrable (fixnum-2-args/operate-constant operator)
+ (lookup-arithmetic-method operator fixnum-methods/2-args-constant))
+
+(define (fixnum-2-args/commutative? operator)
+ (memq operator '(PLUS-FIXNUM
+ MULTIPLY-FIXNUM
+ FIXNUM-AND
+ FIXNUM-OR
+ FIXNUM-XOR)))
+\f
+(define ((fixnum-2-args/standard commutative? operate) target source1
+ source2 overflow?)
+ overflow? ; ignored
+ (two-arg-register-operation operate
+ commutative?
+ target
+ source1
+ source2))
+
+(define (two-arg-register-operation operate commutative?
+ target source1 source2)
+ (let* ((worst-case
+ (lambda (target source1 source2)
+ (LAP (MOV W ,target ,source1)
+ ,@(operate target source2))))
+ (new-target-alias!
+ (lambda ()
+ (let ((source1 (any-reference source1))
+ (source2 (any-reference source2)))
+ (delete-dead-registers!)
+ (worst-case (target-register-reference target)
+ source1
+ source2)))))
+ (cond ((not (pseudo-register? target))
+ (if (not (eq? (register-type target) 'GENERAL))
+ (error "two-arg-register-operation: Wrong type register"
+ target 'GENERAL)
+ (worst-case (register-reference target)
+ (any-reference source1)
+ (any-reference source2))))
+ ((register-copy-if-available source1 'GENERAL target)
+ =>
+ (lambda (get-alias-ref)
+ (if (= source2 source1)
+ (let ((ref (get-alias-ref)))
+ (operate ref ref))
+ (let ((source2 (any-reference source2)))
+ (operate (get-alias-ref) source2)))))
+ ((not commutative?)
+ (new-target-alias!))
+ ((register-copy-if-available source2 'GENERAL target)
+ =>
+ (lambda (get-alias-ref)
+ (let ((source1 (any-reference source1)))
+ (operate (get-alias-ref) source1))))
+ (else
+ (new-target-alias!)))))
+
+(define (fixnum-2-args/register*constant operator target
+ source constant overflow?)
+ (fixnum-1-arg
+ target source
+ (lambda (target)
+ ((fixnum-2-args/operate-constant operator) target constant overflow?))))
+\f
+;;;; Arithmetic operations
+
+(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target)
+ (add-fixnum-constant target 1 false)))
+
+(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target)
+ (add-fixnum-constant target -1 false)))
+
+(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
+ (lambda (target)
+ (LAP (NOT W ,target)
+ ,@(word->fixnum target))))
+
+(define-arithmetic-method 'FIXNUM-NEGATE fixnum-methods/1-arg
+ (lambda (target)
+ (LAP (NEG W ,target))))
+
+(let-syntax
+ ((binary-operation
+ (macro (name instr commutative? idempotent?)
+ `(define-arithmetic-method ',name fixnum-methods/2-args
+ (fixnum-2-args/standard
+ ,commutative?
+ (lambda (target source2)
+ (if (and ,idempotent? (equal? target source2))
+ (LAP)
+ (LAP (,instr W ,',target ,',source2)))))))))
+
+ #| (binary-operation PLUS-FIXNUM ADD true false) |#
+ (binary-operation MINUS-FIXNUM SUB false false)
+ (binary-operation FIXNUM-AND AND true true)
+ (binary-operation FIXNUM-OR OR true true)
+ (binary-operation FIXNUM-XOR XOR true false))
+
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
+ (let* ((operate
+ (lambda (target source2)
+ (LAP (ADD W ,target ,source2))))
+ (standard (fixnum-2-args/standard true operate)))
+
+ (lambda (target source1 source2 overflow?)
+ (if overflow?
+ (standard target source1 source2 overflow?)
+ (let ((one (register-alias source1 'GENERAL))
+ (two (register-alias source2 'GENERAL)))
+ (cond ((not (and one two))
+ (standard target source1 source2 overflow?))
+ ((register-copy-if-available source1 'GENERAL target)
+ =>
+ (lambda (get-tgt)
+ (operate (get-tgt) (register-reference two))))
+ ((register-copy-if-available source2 'GENERAL target)
+ =>
+ (lambda (get-tgt)
+ (operate (get-tgt) (register-reference one))))
+ (else
+ (let ((target (target-register-reference target)))
+ (LAP (LEA ,target (@RI ,one ,two 1)))))))))))
+\f
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
+ (fixnum-2-args/standard
+ false
+ (lambda (target source2)
+ (if (equal? target source2)
+ (load-fixnum-constant 0 target)
+ (let ((temp (temporary-register-reference)))
+ (LAP ,@(if (equal? temp source2)
+ (LAP)
+ (LAP (MOV W ,temp ,source2)))
+ (NOT W ,temp)
+ (AND W ,target ,temp)))))))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
+ (fixnum-2-args/standard
+ false
+ (lambda (target source2)
+ (cond ((not (equal? target source2))
+ (LAP (SAR W ,target (& ,scheme-type-width))
+ (IMUL W ,target ,source2)))
+ ((even? scheme-type-width)
+ (LAP (SAR W ,target (& ,(quotient scheme-type-width 2)))
+ (IMUL W ,target ,target)))
+ (else
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV W ,temp ,target)
+ (SAR W ,target (& ,scheme-type-width))
+ (IMUL W ,target ,temp))))))))
+
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
+ (let ((operate
+ (lambda (target source2)
+ ;; SOURCE2 is guaranteed not to be ECX because of the
+ ;; require-register! used below.
+ ;; TARGET can be ECX only if the rule has machine register
+ ;; ECX as the target, unlikely, but it must be handled!
+ (let ((with-target
+ (lambda (target)
+ (let ((jlabel (generate-label 'SHIFT-JOIN))
+ (slabel (generate-label 'SHIFT-NEGATIVE)))
+ (LAP (MOV W (R ,ecx) ,source2)
+ (SAR W (R ,ecx) (& ,scheme-type-width))
+ (JS B (@PCR ,slabel))
+ (SHL W ,target (R ,ecx))
+ (JMP B (@PCR ,jlabel))
+ (LABEL ,slabel)
+ (NEG W (R ,ecx))
+ (SHR W ,target (R ,ecx))
+ ,@(word->fixnum target)
+ (LABEL ,jlabel))))))
+
+ (if (not (equal? target (INST-EA (R ,ecx))))
+ (with-target target)
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV W ,temp ,target)
+ ,@(with-target temp)
+ (MOV W ,target ,temp))))))))
+ (lambda (target source1 source2 overflow?)
+ overflow? ; ignored
+ (require-register! ecx)
+ (two-arg-register-operation operate
+ false
+ target
+ source1
+ source2))))
+\f
+(define (do-division target source1 source2 result-reg)
+ (prefix-instructions! (load-machine-register! source1 eax))
+ (need-register! eax)
+ (require-register! edx)
+ (rtl-target:=machine-register! target result-reg)
+ (let ((source2 (any-reference source2)))
+ (LAP (MOV W (R ,edx) (R ,eax))
+ (SAR W (R ,edx) (& 31))
+ (IDIV W (R ,eax) ,source2))))
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
+ (lambda (target source1 source2 overflow?)
+ overflow? ; ignored
+ (if (= source2 source1)
+ (load-fixnum-constant 1 (target-register-reference target))
+ (LAP ,@(do-division target source1 source2 eax)
+ (SAL W (R ,eax) (& ,scheme-type-width))))))
+
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
+ (lambda (target source1 source2 overflow?)
+ overflow? ; ignored
+ (if (= source2 source1)
+ (load-fixnum-constant 0 (target-register-reference target))
+ (do-division target source1 source2 edx))))
+
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ (add-fixnum-constant target n overflow?)))
+
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ (add-fixnum-constant target (- 0 n) overflow?)))
+
+(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (LAP))
+ ((= n -1)
+ (load-fixnum-constant -1 target))
+ (else
+ (LAP (OR W ,target (& ,(* n fixnum-1))))))))
+
+(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (LAP))
+ ((= n -1)
+ (LAP (NOT W ,target)
+ ,@(word->fixnum target)))
+ (else
+ (LAP (XOR W ,target (& ,(* n fixnum-1))))))))
+
+(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (load-fixnum-constant 0 target))
+ ((= n -1)
+ (LAP))
+ (else
+ (LAP (AND W ,target (& ,(* n fixnum-1))))))))
+\f
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (LAP))
+ ((= n -1)
+ (load-fixnum-constant 0 target))
+ (else
+ (LAP (AND W ,target (& ,(* (fix:not n) fixnum-1))))))))
+
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (LAP))
+ ((not (<= (- 0 scheme-datum-width) n scheme-datum-width))
+ (load-fixnum-constant 0 target))
+ ((not (negative? n))
+ (LAP (SHL W ,target (& ,n))))
+ (else
+ (LAP (SHR W ,target (& ,(- 0 n)))
+ ,@(word->fixnum target))))))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ (multiply-fixnum-constant target n overflow?)))
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((= n 1)
+ (LAP))
+ ((= n -1)
+ (LAP (NEG W ,target)))
+ ((integer-power-of-2? (if (negative? n) (- 0 n) n))
+ =>
+ (lambda (expt-of-2)
+ (let ((label (generate-label 'QUO-SHIFT))
+ (absn (if (negative? n) (- 0 n) n)))
+ (LAP (CMP W ,target (& 0))
+ (JGE B (@PCR ,label))
+ (ADD W ,target (& ,(* (-1+ absn) fixnum-1)))
+ (LABEL ,label)
+ (SAR W ,target (& ,expt-of-2))
+ ,@(word->fixnum target)
+ ,@(if (negative? n)
+ (LAP (NEG W ,target))
+ (LAP))))))
+ (else
+ (error "Fixnum-quotient/constant: Bad value" n)))))
+\f
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ ;; (remainder x y) is 0 or has the sign of x.
+ ;; Thus we can always "divide" by (abs y) to make things simpler.
+ overflow? ; ignored
+ (let ((n (if (negative? n) (- 0 n) n)))
+ (cond ((= n 1)
+ (load-fixnum-constant 0 target))
+ ((integer-power-of-2? n)
+ (let ((sign (temporary-register-reference))
+ (label (generate-label 'REM-MERGE)))
+ ;; This may produce a branch to a branch, but a
+ ;; peephole optimizer should be able to fix this.
+ (LAP (MOV W ,sign ,target)
+ (AND W ,target (& ,(* (-1+ n) fixnum-1)))
+ (JZ B (@PCR ,label))
+ (SAR W ,sign (& ,(-1+ scheme-object-width)))
+ (AND W ,sign (& ,(* n (- 0 fixnum-1))))
+ (OR W ,target ,sign)
+ (LABEL ,label))))
+ (else
+ (error "Fixnum-remainder/constant: Bad value" n))))))
+
+(define (fixnum-predicate/unary->binary predicate)
+ (case predicate
+ ((ZERO-FIXNUM?) 'EQUAL-FIXNUM?)
+ ((NEGATIVE-FIXNUM?) 'LESS-THAN-FIXNUM?)
+ ((POSITIVE-FIXNUM?) 'GREATER-THAN-FIXNUM?)
+ (else
+ (error "fixnum-predicate/unary->binary: Unknown unary predicate"
+ predicate))))
+
+(define (commute-fixnum-predicate predicate)
+ (case predicate
+ ((EQUAL-FIXNUM?) 'EQUAL-FIXNUM?)
+ ((LESS-THAN-FIXNUM?) 'GREATER-THAN-FIXNUM?)
+ ((GREATER-THAN-FIXNUM?) 'LESS-THAN-FIXNUM?)
+ (else
+ (error "commute-fixnum-predicate: Unknown predicate"
+ predicate))))
+
+(define (fixnum-branch! predicate)
+ (case predicate
+ ((EQUAL-FIXNUM? ZERO-FIXNUM?)
+ (set-equal-branches!))
+ ((LESS-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label)
+ (LAP (JL (@PCR ,label))))
+ (lambda (label)
+ (LAP (JGE (@PCR ,label))))))
+ ((GREATER-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label)
+ (LAP (JG (@PCR ,label))))
+ (lambda (label)
+ (LAP (JLE (@PCR ,label))))))
+ ((NEGATIVE-FIXNUM?)
+ (set-current-branches! (lambda (label)
+ (LAP (JS (@PCR ,label))))
+ (lambda (label)
+ (LAP (JNS (@PCR ,label))))))
+ ((POSITIVE-FIXNUM?)
+ (error "fixnum-branch!: Cannot handle directly" predicate))
+ (else
+ (error "fixnum-branch!: Unknown predicate" predicate))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulflo.scm,v 1.1 1995/01/10 20:53:07 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Flonum rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;; ****
+;; Missing: 2 argument operations and predicates with non-trivial
+;; constant arguments.
+;; Also missing with (OBJECT->FLOAT (REGISTER ...)) operands.
+;; ****
+
+(define (flonum-source! register)
+ (floreg->sti (load-alias-register! register 'FLOAT)))
+
+(define (flonum-target! pseudo-register)
+ (delete-dead-registers!)
+ (floreg->sti (allocate-alias-register! pseudo-register 'FLOAT)))
+
+(define (flonum-temporary!)
+ (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 (register-alias source 'FLOAT))
+ (target (target-register-reference target)))
+ (LAP (MOV W (@R ,regnum:free-pointer)
+ (&U ,(make-non-pointer-literal
+ (ucode-type manifest-nm-vector)
+ 2)))
+ ,@(if (not source)
+ ;; Value is in memory home
+ (let ((off (pseudo-register-offset source))
+ (temp (temporary-register-reference)))
+ (LAP (MOV W ,target
+ ,(offset-reference regnum:regs-pointer off))
+ (MOV W ,temp
+ ,(offset-reference regnum:regs-pointer (1+ off)))
+ (MOV W (@RO B ,regnum:free-pointer 4) ,target)
+ (MOV W (@RO B ,regnum:free-pointer 8) ,temp)))
+ (store-float (floreg->sti source)
+ (INST-EA (@RO B ,regnum:free-pointer 4))))
+ (LEA ,target
+ (@RO UW ,regnum:free-pointer
+ ,(make-non-pointer-literal (ucode-type flonum) 0)))
+ (ADD W (R ,regnum:free-pointer) (& 12)))))
+
+(define-rule statement
+ ;; convert a flonum object to a floating-point number
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
+ (let* ((source (move-to-temporary-register! source 'GENERAL))
+ (target (flonum-target! target)))
+ (LAP ,@(object->address (register-reference source))
+ ,@(load-float (INST-EA (@RO B ,source 4)) target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->FLOAT (CONSTANT (? value flonum-bit?))))
+ (let ((target (flonum-target! target)))
+ (LAP ,@(if (= value 0.)
+ (LAP (FLDZ))
+ (LAP (FLD1)))
+ (FSTP (ST ,(1+ target))))))
+
+(define (flonum-bit? value)
+ (and (or (= value 0.) (= value 1.))
+ value))
+\f
+;;;; Floating-point vector support.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:simple-float-offset?))
+ (let* ((source (float-offset->reference! expression))
+ (target (flonum-target! target)))
+ (load-float source target)))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-float-offset?) (REGISTER (? source)))
+ (let ((source (flonum-source! source))
+ (target (float-offset->reference! expression)))
+ (store-float source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (? expression rtl:detagged-float-offset?))
+ (with-detagged-float-location expression
+ (lambda (temp)
+ (load-float temp target))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-float-offset?)
+ (REGISTER (? source)))
+ (with-detagged-float-location expression
+ (lambda (temp)
+ (store-float (flonum-source! source) temp))))
+
+(define (with-detagged-float-location rtl-expression recvr)
+ ;; Never needs to protect a register because it is a float register!
+ (with-decoded-detagged-float-offset rtl-expression
+ (lambda (base index w-offset)
+ (with-indexed-address base index 8 (* 4 w-offset) false recvr))))
+
+(define (rtl:detagged-float-offset? expression)
+ (and (rtl:float-offset? expression)
+ (let ((base (rtl:float-offset-base expression))
+ (offset (rtl:float-offset-offset expression)))
+ (and (rtl:offset-address? base)
+ (rtl:machine-constant? (rtl:offset-address-offset base))
+ (rtl:detagged-index? (rtl:offset-address-base base)
+ offset)))
+ expression))
+
+(define (with-decoded-detagged-float-offset expression recvr)
+ (let ((base (rtl:float-offset-base expression))
+ (index (rtl:float-offset-offset expression)))
+ (let ((base* (rtl:offset-address-base base)))
+ (recvr (rtl:register-number (if (rtl:register? base*)
+ base*
+ (rtl:object->address-expression base*)))
+ (rtl:register-number (if (rtl:register? index)
+ index
+ (rtl:object->datum-expression index)))
+ (rtl:machine-constant-value (rtl:offset-address-offset base))))))
+
+(define (load-float ea sti)
+ (LAP (FLD D ,ea)
+ (FSTP (ST ,(1+ sti)))))
+
+(define (store-float sti ea)
+ (if (zero? sti)
+ (LAP (FST D ,ea))
+ (LAP (FLD (ST ,sti))
+ (FSTP D ,ea))))
+\f
+;;;; Flonum Arithmetic
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
+ overflow? ;ignore
+ ((flonum-1-arg/operator operation) target source))
+
+(define ((flonum-unary-operation/general operate) target source)
+ (let* ((source (flonum-source! source))
+ (target (flonum-target! target)))
+ (operate 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
+ (flonum-unary-operation/general
+ (lambda (target source)
+ (if (and (zero? target) (zero? source))
+ (LAP (,opcode))
+ (LAP (FLD (ST ,', source))
+ (,opcode)
+ (FSTP (ST ,',(1+ target)))))))))))
+ (define-flonum-operation FLONUM-NEGATE FCHS)
+ (define-flonum-operation FLONUM-ABS FABS)
+ (define-flonum-operation FLONUM-SIN FSIN)
+ (define-flonum-operation FLONUM-COS FCOS)
+ (define-flonum-operation FLONUM-SQRT FSQRT)
+ (define-flonum-operation FLONUM-ROUND FRNDINT))
+
+;; These (and FLONUM-ROUND above) presume that the default rounding mode
+;; is round-to-nearest/even
+
+(define (define-rounding prim-name mode)
+ (define-arithmetic-method prim-name flonum-methods/1-arg
+ (flonum-unary-operation/general
+ (lambda (target source)
+ (let ((temp (temporary-register-reference)))
+ (LAP (FSTCW (@R ,regnum:free-pointer))
+ ,@(if (and (zero? target) (zero? source))
+ (LAP)
+ (LAP (FLD (ST ,source))))
+ (MOV B ,temp (@RO B ,regnum:free-pointer 1))
+ (OR B (@RO B ,regnum:free-pointer 1) (&U ,mode))
+ (FNLDCW (@R ,regnum:free-pointer))
+ (FRNDINT)
+ (MOV B (@RO B ,regnum:free-pointer 1) ,temp)
+ ,@(if (and (zero? target) (zero? source))
+ (LAP)
+ (LAP (FSTP (ST ,(1+ target)))))
+ (FNLDCW (@R ,regnum:free-pointer))))))))
+
+(define-rounding 'FLONUM-CEILING #x08)
+(define-rounding 'FLONUM-FLOOR #x04)
+(define-rounding 'FLONUM-TRUNCATE #x0c)
+\f
+;; This is used in order to avoid using two stack locations for
+;; the remainder unary operations.
+
+(define ((flonum-unary-operation/stack-top operate) target source)
+ (define (finish source->top)
+ ;; Perhaps this can be improved?
+ (rtl-target:=machine-register! target fr0)
+ (LAP ,@source->top
+ ,@(operate)))
+
+ (if (or (machine-register? source)
+ (not (is-alias-for-register? fr0 source))
+ (not (dead-register? source)))
+ (finish (load-machine-register! source fr0))
+ (begin
+ (delete-dead-registers!)
+ (finish (LAP)))))
+
+(define-arithmetic-method 'FLONUM-LOG flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ #|
+ (LAP (FLDLN2)
+ (FLD (ST ,(1+ source)))
+ (FYL2X)
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FLDLN2)
+ (FXCH (ST 0) (ST 1))
+ (FYL2X)))))
+
+(define-arithmetic-method 'FLONUM-EXP flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ #|
+ (LAP (FLD (ST ,source))
+ (FLDL2E)
+ (FMULP (ST 1) (ST 0))
+ (F2XM1)
+ (FLD1)
+ (FADDP (ST 1) (ST 0))
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FLDL2E)
+ (FMULP (ST 1) (ST 0))
+ (F2XM1)
+ (FLD1)
+ (FADDP (ST 1) (ST 0))))))
+
+(define-arithmetic-method 'FLONUM-TAN flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ #|
+ (LAP (FLD (ST ,source))
+ (FPTAN)
+ (FSTP (ST 0)) ; FPOP
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FPTAN)
+ (FSTP (ST 0)) ; FPOP
+ ))))
+\f
+(define-arithmetic-method 'FLONUM-ATAN flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ #|
+ (LAP (FLD (ST ,source))
+ (FLD1)
+ (FPATAN)
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FLD1)
+ (FPATAN)))))
+
+;; For now, these preserve values in memory
+;; in order to avoid flushing a stack location.
+
+(define-arithmetic-method 'FLONUM-ACOS flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ #|
+ (LAP (FLD (ST ,source))
+ (FMUL (ST 0) (ST 0))
+ (FLD1)
+ (F%SUBP (ST 1) (ST 0))
+ (FSQRT)
+ (FLD (ST ,(1+ source)))
+ (FPATAN)
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FST D (@R ,regnum:free-pointer))
+ (FMUL (ST 0) (ST 0))
+ (FLD1)
+ (F%SUBP (ST 1) (ST 0))
+ (FSQRT)
+ (FLD D (@R ,regnum:free-pointer))
+ (FPATAN)))))
+
+(define-arithmetic-method 'FLONUM-ASIN flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ #|
+ (LAP (FLD (ST ,source))
+ (FMUL (ST 0) (ST 0))
+ (FLD1)
+ (F%SUBP (ST 1) (ST 0))
+ (FSQRT)
+ (FLD (ST ,(1+ source)))
+ (FXCH (ST 0) (ST 1))
+ (FPATAN)
+ (FSTP (ST ,(1+ target))))
+ |#
+ (LAP (FST D (@R ,regnum:free-pointer))
+ (FMUL (ST 0) (ST 0))
+ (FLD1)
+ (F%SUBP (ST 1) (ST 0))
+ (FSQRT)
+ (FLD D (@R ,regnum:free-pointer))
+ (FXCH (ST 0) (ST 1))
+ (FPATAN)))))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ overflow? ;ignore
+ ((flonum-2-args/operator operation) target source1 source2))
+
+(define ((flonum-binary-operation operate) target source1 source2)
+ (let ((default
+ (lambda ()
+ (let* ((sti1 (flonum-source! source1))
+ (sti2 (flonum-source! source2)))
+ (operate (flonum-target! target) sti1 sti2)))))
+ (cond ((pseudo-register? target)
+ (reuse-pseudo-register-alias
+ source1 'FLOAT
+ (lambda (alias)
+ (let* ((sti1 (floreg->sti alias))
+ (sti2 (if (= source1 source2)
+ sti1
+ (flonum-source! source2))))
+ (delete-register! alias)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target alias)
+ (operate sti1 sti1 sti2)))
+ (lambda ()
+ (reuse-pseudo-register-alias
+ source2 'FLOAT
+ (lambda (alias2)
+ (let ((sti1 (flonum-source! source1))
+ (sti2 (floreg->sti alias2)))
+ (delete-register! alias2)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target alias2)
+ (operate sti2 sti1 sti2)))
+ default))))
+ ((not (eq? (register-type target) 'FLOAT))
+ (error "flonum-2-args: Wrong type register"
+ target 'FLOAT))
+ (else
+ (default)))))
+
+(define (flonum-2-args/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/2-args))
+
+(define flonum-methods/2-args
+ (list 'FLONUM-METHODS/2-ARGS))
+
+(define (flonum-1-arg%1/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/1-arg%1))
+
+(define flonum-methods/1-arg%1
+ (list 'FLONUM-METHODS/1-ARG%1))
+
+(define (flonum-1%1-arg/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/1%1-arg))
+
+(define flonum-methods/1%1-arg
+ (list 'FLONUM-METHODS/1%1-ARG))
+
+(define (binary-flonum-arithmetic? operation)
+ (memq operation '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)))
+\f
+(let-syntax
+ ((define-flonum-operation
+ (macro (primitive-name op1%2 op1%2p op2%1 op2%1p)
+ `(begin
+ (define-arithmetic-method ',primitive-name flonum-methods/2-args
+ (flonum-binary-operation
+ (lambda (target source1 source2)
+ (cond ((= target source1)
+ (cond ((zero? target)
+ (LAP (,op1%2 (ST 0) (ST ,',source2))))
+ ((zero? source2)
+ (LAP (,op2%1 (ST ,',target) (ST 0))))
+ (else
+ (LAP (FLD (ST ,',source2))
+ (,op2%1p (ST ,',(1+ target)) (ST 0))))))
+ ((= target source2)
+ (cond ((zero? target)
+ (LAP (,op2%1 (ST 0) (ST ,',source1))))
+ ((zero? source1)
+ (LAP (,op1%2 (ST ,',target) (ST 0))))
+ (else
+ (LAP (FLD (ST ,',source1))
+ (,op1%2p (ST ,',(1+ target)) (ST 0))))))
+ (else
+ (LAP (FLD (ST ,',source1))
+ (,op1%2 (ST 0) (ST ,',(1+ source2)))
+ (FSTP (ST ,',(1+ target)))))))))
+
+ (define-arithmetic-method ',primitive-name flonum-methods/1%1-arg
+ (flonum-unary-operation/general
+ (lambda (target source)
+ (if (= source target)
+ (LAP (FLD1)
+ (,op1%2p (ST ,',(1+ target)) (ST 0)))
+ (LAP (FLD1)
+ (,op1%2 (ST 0) (ST ,',(1+ source)))
+ (FSTP (ST ,',(1+ target))))))))
+
+ (define-arithmetic-method ',primitive-name flonum-methods/1-arg%1
+ (flonum-unary-operation/general
+ (lambda (target source)
+ (if (= source target)
+ (LAP (FLD1)
+ (,op2%1p (ST ,',(1+ target)) (ST 0)))
+ (LAP (FLD1)
+ (,op2%1 (ST 0) (ST ,',(1+ source)))
+ (FSTP (ST ,',(1+ target))))))))))))
+
+ (define-flonum-operation FLONUM-ADD FADD FADDP FADD FADDP)
+ (define-flonum-operation FLONUM-SUBTRACT F%SUB F%SUBP F%SUBR F%SUBPR)
+ (define-flonum-operation FLONUM-MULTIPLY FMUL FMULP FMUL FMULP)
+ (define-flonum-operation FLONUM-DIVIDE F%DIV F%DIVP F%DIVR F%DIVPR))
+
+(define-arithmetic-method 'FLONUM-ATAN2 flonum-methods/2-args
+ (lambda (target source1 source2)
+ (if (and (not (machine-register? source1))
+ (is-alias-for-register? fr0 source1)
+ (dead-register? source1))
+ (let ((source2 (flonum-source! source2)))
+ (delete-dead-registers!)
+ (rtl-target:=machine-register! target fr0)
+ (LAP (FLD (ST ,source2))
+ (FPATAN)))
+ (begin
+ (prefix-instructions! (load-machine-register! source1 fr0))
+ (need-register! fr0)
+ (let ((source2 (if (= source2 source1)
+ fr0
+ (flonum-source! source2))))
+ (delete-dead-registers!)
+ (rtl-target:=machine-register! target fr0)
+ (LAP (FLD (ST ,source2))
+ (FPATAN)))))))
+\f
+(define-arithmetic-method 'FLONUM-REMAINDER flonum-methods/2-args
+ (flonum-binary-operation
+ (lambda (target source1 source2)
+ (if (zero? source2)
+ (LAP (FLD (ST ,source1))
+ (FPREM1)
+ (FSTP (ST ,(1+ target))))
+ #|
+ ;; This sequence is one cycle shorter than the one below,
+ ;; but needs two spare stack locations instead of one.
+ ;; Since FPREM1 is a variable, very slow instruction,
+ ;; the difference in time will hardly be noticeable
+ ;; but the availability of an extra "register" may be.
+ (LAP (FLD (ST ,source2))
+ (FLD (ST ,source1))
+ (FPREM1)
+ (FSTP (ST ,(+ target 2)))
+ (FSTP (ST 0))) ; FPOP
+ |#
+ (LAP (FXCH (ST 0) (ST ,source2))
+ (FLD (ST ,(if (zero? source1) source2 source1)))
+ (FPREM1)
+ (FSTP (ST ,(1+ (if (= target source2)
+ 0
+ target))))
+ (FXCH (ST 0) (ST ,source2)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS FLONUM-SUBTRACT
+ (OBJECT->FLOAT (CONSTANT 0.))
+ (REGISTER (? source))
+ (? overflow?)))
+ overflow? ;ignore
+ ((flonum-unary-operation/general
+ (lambda (target source)
+ (if (and (zero? target) (zero? source))
+ (LAP (FCHS))
+ (LAP (FLD (ST ,source))
+ (FCHS)
+ (FSTP (ST ,(1+ target)))))))
+ target source))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (REGISTER (? source))
+ (OBJECT->FLOAT (CONSTANT 1.))
+ (? overflow?)))
+ (QUALIFIER (binary-flonum-arithmetic? operation))
+ overflow? ;ignore
+ ((flonum-1-arg%1/operator operation) target source))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (OBJECT->FLOAT (CONSTANT 1.))
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER (binary-flonum-arithmetic? operation))
+ overflow? ;ignore
+ ((flonum-1%1-arg/operator operation) target source))
+\f
+;;;; Flonum Predicates
+
+(define-rule predicate
+ (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ (flonum-compare-zero predicate source))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (let* ((st1 (flonum-source! source1))
+ (st2 (flonum-source! source2)))
+ (cond ((zero? st1)
+ (flonum-branch! predicate
+ (LAP (FCOM (ST 0) (ST ,st2)))))
+ ((zero? st2)
+ (flonum-branch! (commute-flonum-predicate predicate)
+ (LAP (FCOM (ST 0) (ST ,st1)))))
+ (else
+ (flonum-branch! predicate
+ (LAP (FLD (ST ,st1))
+ (FCOMP (ST 0) (ST ,(1+ st2)))))))))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source))
+ (OBJECT->FLOAT (CONSTANT 0.)))
+ (flonum-compare-zero predicate source))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FLOAT (CONSTANT 0.))
+ (REGISTER (? source)))
+ (flonum-compare-zero (commute-flonum-predicate predicate) source))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source))
+ (OBJECT->FLOAT (CONSTANT 1.)))
+ (flonum-compare-one predicate source))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FLOAT (CONSTANT 1.))
+ (REGISTER (? source)))
+ (flonum-compare-one (commute-flonum-predicate predicate) source))
+\f
+(define (flonum-compare-zero predicate source)
+ (let ((sti (flonum-source! source)))
+ (if (zero? sti)
+ (flonum-branch! predicate
+ (LAP (FTST)))
+ (flonum-branch! (commute-flonum-predicate predicate)
+ (LAP (FLDZ)
+ (FCOMP (ST 0) (ST ,(1+ sti))))))))
+
+(define (flonum-compare-one predicate source)
+ (let ((sti (flonum-source! source)))
+ (flonum-branch! (commute-flonum-predicate predicate)
+ (LAP (FLD1)
+ (FCOMP (ST 0) (ST ,(1+ sti)))))))
+
+(define (commute-flonum-predicate pred)
+ (case pred
+ ((FLONUM-EQUAL? FLONUM-ZERO?) 'FLONUM-EQUAL?)
+ ((FLONUM-LESS? FLONUM-NEGATIVE?) 'FLONUM-GREATER?)
+ ((FLONUM-GREATER? FLONUM-POSITIVE?) 'FLONUM-LESS?)
+ (else
+ (error "commute-flonum-predicate: Unknown predicate" pred))))
+
+(define (flonum-branch! predicate prefix)
+ (case predicate
+ ((FLONUM-EQUAL? FLONUM-ZERO?)
+ (set-current-branches! (lambda (label)
+ (let ((unordered (generate-label 'UNORDERED)))
+ (LAP (JP (@PCR ,unordered))
+ (JE (@PCR ,label))
+ (LABEL ,unordered))))
+ (lambda (label)
+ (LAP (JNE (@PCR ,label))
+ (JP (@PCR ,label))))))
+ ((FLONUM-LESS? FLONUM-NEGATIVE?)
+ (set-current-branches! (lambda (label)
+ (let ((unordered (generate-label 'UNORDERED)))
+ (LAP (JP (@PCR ,unordered))
+ (JB (@PCR ,label))
+ (LABEL ,unordered))))
+ (lambda (label)
+ (LAP (JAE (@PCR ,label))
+ (JP (@PCR ,label))))))
+ ((FLONUM-GREATER? FLONUM-POSITIVE?)
+ (set-current-branches! (lambda (label)
+ (LAP (JA (@PCR ,label))))
+ (lambda (label)
+ (LAP (JBE (@PCR ,label))))))
+ (else
+ (error "flonum-branch!: Unknown predicate" predicate)))
+ (flush-register! eax)
+ (LAP ,@prefix
+ (FSTSW (R ,eax))
+ (SAHF)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulrew.scm,v 1.1 1995/01/10 20:53:08 adams Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rewrite Rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Synthesized Data
+
+(define-rule rewriting
+ (CONS-NON-POINTER (? type) (? datum))
+ ;; On i386, there's no difference between an address and a datum,
+ ;; so the rules for constructing non-pointer objects are the same as
+ ;; those for pointer objects.
+ (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
+ (QUALIFIER (rtl:machine-constant? type))
+ (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
+ (QUALIFIER
+ (and (rtl:object->type? type)
+ (rtl:constant? (rtl:object->type-expression type))))
+ (rtl:make-cons-pointer
+ (rtl:make-machine-constant
+ (object-type (rtl:constant-value (rtl:object->type-expression datum))))
+ datum))
+
+(define-rule rewriting
+ (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
+ (QUALIFIER (rtl:machine-constant? datum))
+ (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+ (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
+ (QUALIFIER
+ (and (rtl:object->datum? datum)
+ (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
+ (rtl:make-cons-pointer
+ type
+ (rtl:make-machine-constant
+ (careful-object-datum
+ (rtl:constant-value (rtl:object->datum-expression datum))))))
+
+(define-rule rewriting
+ (OBJECT->TYPE (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant? source))
+ (rtl:make-machine-constant (object-type (rtl:constant-value source))))
+
+(define-rule rewriting
+ (OBJECT->DATUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-non-pointer? source))
+ (rtl:make-machine-constant
+ (careful-object-datum (rtl:constant-value source))))
+
+(define (rtl:constant-non-pointer? expression)
+ (and (rtl:constant? expression)
+ (non-pointer-object? (rtl:constant-value expression))))
+\f
+;;; These rules are losers because there's no abstract way to cons a
+;;; statement or a predicate without also getting some CFG structure.
+
+(define-rule rewriting
+ (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'ASSIGN target comparand))
+
+(define-rule rewriting
+ (ASSIGN (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset)))
+ (REGISTER (? source register-known-value)))
+ (QUALIFIER
+ (and (rtl:byte-offset-address? source)
+ (rtl:machine-constant? (rtl:byte-offset-address-offset source))
+ (let ((base (let ((base (rtl:byte-offset-address-base source)))
+ (if (rtl:register? base)
+ (register-known-value (rtl:register-number base))
+ base))))
+ (and base
+ (rtl:offset? base)
+ (let ((base* (rtl:offset-base base))
+ (offset* (rtl:offset-offset base)))
+ (and (rtl:machine-constant? offset*)
+ (= (rtl:register-number base*) address)
+ (= (rtl:machine-constant-value offset*) offset)))))))
+ (let ((target (let ((base (rtl:byte-offset-address-base source)))
+ (if (rtl:register? base)
+ (register-known-value (rtl:register-number base))
+ base))))
+ (list 'ASSIGN
+ target
+ (rtl:make-byte-offset-address
+ target
+ (rtl:byte-offset-address-offset source)))))
+
+(define-rule rewriting
+ (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source comparand))
+
+(define-rule rewriting
+ (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source comparand))
+
+(define (rtl:immediate-zero-constant? expression)
+ (cond ((rtl:constant? expression)
+ (let ((value (rtl:constant-value expression)))
+ (and (non-pointer-object? value)
+ (zero? (object-type value))
+ (zero? (careful-object-datum value)))))
+ ((rtl:cons-pointer? expression)
+ (and (let ((expression (rtl:cons-pointer-type expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))
+ (let ((expression (rtl:cons-pointer-datum expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))))
+ (else false)))
+\f
+;;;; Fixnums
+
+(define-rule rewriting
+ (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-fixnum? source))
+ (rtl:make-object->fixnum source))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (REGISTER (? operand-1 register-known-value))
+ (? operand-2)
+ (? overflow?))
+ (QUALIFIER (rtl:constant-fixnum-test operand-1 (lambda (n) n true)))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ (? overflow?))
+ (QUALIFIER
+ (and (rtl:constant-fixnum-test operand-2 (lambda (n) n true))))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS (? operator)
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ (? overflow?))
+ (QUALIFIER
+ (and (memq operator '(PLUS-FIXNUM MINUS-FIXNUM))
+ (rtl:register? operand-1)
+ (rtl:constant-fixnum-test operand-2 zero?)))
+ (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS (? operator)
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ (? overflow?))
+ (QUALIFIER
+ (and (memq operator '(FIXNUM-QUOTIENT FIXNUM-REMAINDER))
+ (rtl:register? operand-1)
+ (rtl:constant-fixnum-test operand-2
+ (lambda (n)
+ (integer-power-of-2? (abs n))))))
+ (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS FIXNUM-LSH
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ #F)
+ (QUALIFIER (and (rtl:register? operand-1)
+ (rtl:constant-fixnum-test operand-2 (lambda (n) n true))))
+ (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F))
+
+(define (rtl:constant-fixnum? expression)
+ (and (rtl:constant? expression)
+ (fix:fixnum? (rtl:constant-value expression))))
+
+(define (rtl:constant-fixnum-test expression predicate)
+ (and (rtl:object->fixnum? expression)
+ (let ((expression (rtl:object->fixnum-expression expression)))
+ (and (rtl:constant? expression)
+ (let ((n (rtl:constant-value expression)))
+ (and (fix:fixnum? n)
+ (predicate n)))))))
+\f
+(define-rule rewriting
+ (OBJECT->FLOAT (REGISTER (? operand register-known-value)))
+ (QUALIFIER
+ (rtl:constant-flonum-test operand
+ (lambda (v)
+ (or (flo:zero? v) (flo:one? v)))))
+ (rtl:make-object->float operand))
+
+(define-rule rewriting
+ (FLONUM-2-ARGS FLONUM-SUBTRACT
+ (REGISTER (? operand-1 register-known-value))
+ (? operand-2)
+ (? overflow?))
+ (QUALIFIER (rtl:constant-flonum-test operand-1 flo:zero?))
+ (rtl:make-flonum-2-args 'FLONUM-SUBTRACT operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+ (FLONUM-2-ARGS (? operation)
+ (REGISTER (? operand-1 register-known-value))
+ (? operand-2)
+ (? overflow?))
+ (QUALIFIER
+ (and (memq operation
+ '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE))
+ (rtl:constant-flonum-test operand-1 flo:one?)))
+ (rtl:make-flonum-2-args operation operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+ (FLONUM-2-ARGS (? operation)
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ (? overflow?))
+ (QUALIFIER
+ (and (memq operation
+ '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE))
+ (rtl:constant-flonum-test operand-2 flo:one?)))
+ (rtl:make-flonum-2-args operation operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value)))
+ (QUALIFIER (rtl:constant-flonum-test operand-2 flo:zero?))
+ (list 'FLONUM-PRED-2-ARGS predicate operand-1 operand-2))
+
+(define-rule rewriting
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? operand-1 register-known-value))
+ (? operand-2))
+ (QUALIFIER (rtl:constant-flonum-test operand-1 flo:zero?))
+ (list 'FLONUM-PRED-2-ARGS predicate operand-1 operand-2))
+\f
+#|
+;; These don't work as written. They are not simplified and are
+;; therefore passed whole to the back end, and there is no way to
+;; construct the graph at this level.
+
+;; acos (x) = atan ((sqrt (1 - x^2)) / x)
+
+(define-rule add-pre-cse-rewriting-rule!
+ (FLONUM-1-ARG FLONUM-ACOS (? operand) #f)
+ (rtl:make-flonum-2-args
+ 'FLONUM-ATAN2
+ (rtl:make-flonum-1-arg
+ 'FLONUM-SQRT
+ (rtl:make-flonum-2-args
+ 'FLONUM-SUBTRACT
+ (rtl:make-object->float (rtl:make-constant 1.))
+ (rtl:make-flonum-2-args 'FLONUM-MULTIPLY operand operand false)
+ false)
+ false)
+ operand
+ false))
+
+;; asin (x) = atan (x / (sqrt (1 - x^2)))
+
+(define-rule add-pre-cse-rewriting-rule!
+ (FLONUM-1-ARG FLONUM-ASIN (? operand) #f)
+ (rtl:make-flonum-2-args
+ 'FLONUM-ATAN2
+ operand
+ (rtl:make-flonum-1-arg
+ 'FLONUM-SQRT
+ (rtl:make-flonum-2-args
+ 'FLONUM-SUBTRACT
+ (rtl:make-object->float (rtl:make-constant 1.))
+ (rtl:make-flonum-2-args 'FLONUM-MULTIPLY operand operand false)
+ false)
+ false)
+ false))
+
+|#
+
+(define (rtl:constant-flonum-test expression predicate)
+ (and (rtl:object->float? expression)
+ (let ((expression (rtl:object->float-expression expression)))
+ (and (rtl:constant? expression)
+ (let ((n (rtl:constant-value expression)))
+ (and (flo:flonum? n)
+ (predicate n)))))))
+
+(define (flo:one? value)
+ (flo:= value 1.))
+\f
+;;;; Indexed addressing modes
+
+(define-rule rewriting
+ (OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT (? value)))
+ (QUALIFIER (and (rtl:offset-address? base)
+ (rtl:simple-subexpressions? base)))
+ (rtl:make-offset base (rtl:make-machine-constant value)))
+
+(define-rule rewriting
+ (BYTE-OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT (? value)))
+ (QUALIFIER (and (rtl:byte-offset-address? base)
+ (rtl:simple-subexpressions? base)))
+ (rtl:make-byte-offset base (rtl:make-machine-constant value)))
+
+(define-rule rewriting
+ (FLOAT-OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT (? value)))
+ (QUALIFIER (and (rtl:float-offset-address? base)
+ (rtl:simple-subexpressions? base)))
+ (if (zero? value)
+ (rtl:make-float-offset
+ (rtl:float-offset-address-base base)
+ (rtl:float-offset-address-offset base))
+ (rtl:make-float-offset base (rtl:make-machine-constant value))))
+
+(define-rule rewriting
+ (FLOAT-OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT (? value)))
+ (QUALIFIER
+ (and (rtl:offset-address? base)
+ (rtl:simple-subexpressions? base)
+ (rtl:machine-constant? (rtl:offset-address-offset base))))
+ (rtl:make-float-offset base (rtl:make-machine-constant value)))
+
+;; This is here to avoid generating things like
+;;
+;; (offset (offset-address (object->address (constant #(foo bar baz gack)))
+;; (register 29))
+;; (machine-constant 1))
+;;
+;; since the offset-address subexpression is constant, and therefore
+;; known!
+
+(define (rtl:simple-subexpressions? expr)
+ (for-all? (cdr expr)
+ (lambda (sub)
+ (or (rtl:machine-constant? sub)
+ (rtl:register? sub)))))
+
+
projects / mit-scheme.git / commitdiff