From: Stephen Adams Date: Tue, 10 Jan 1995 20:53:08 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~6773 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cebb33f8edd8ec3e5a0510374dffa1b6eb6c8349;p=mit-scheme.git Initial revision --- diff --git a/v8/src/compiler/machines/i386/assmd.scm b/v8/src/compiler/machines/i386/assmd.scm new file mode 100644 index 000000000..c925aa9fc --- /dev/null +++ b/v8/src/compiler/machines/i386/assmd.scm @@ -0,0 +1,86 @@ +#| -*-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)) + +(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 diff --git a/v8/src/compiler/machines/i386/coerce.scm b/v8/src/compiler/machines/i386/coerce.scm new file mode 100644 index 000000000..712854f69 --- /dev/null +++ b/v8/src/compiler/machines/i386/coerce.scm @@ -0,0 +1,56 @@ +#| -*-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)) + +;; *** 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 diff --git a/v8/src/compiler/machines/i386/dassm1.scm b/v8/src/compiler/machines/i386/dassm1.scm new file mode 100644 index 000000000..df50921ea --- /dev/null +++ b/v8/src/compiler/machines/i386/dassm1.scm @@ -0,0 +1,288 @@ +#| -*-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)) + +;;; 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))))) + +(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))))))) + +(define (disassembler/write-constants-block block symbol-table) + (fluid-let ((*unparser-radix* 16)) + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/constants-start block))) + (cond ((not (< index end)) 'DONE) + ((object-type? + (let-syntax ((ucode-type + (macro (name) (microcode-type name)))) + (ucode-type linkage-section)) + (system-vector-ref block index)) + (loop (disassembler/write-linkage-section block + symbol-table + index))) + (else + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-constant block + symbol-table + (system-vector-ref block index)))) + (loop (1+ index)))))))) + +(define (write-constant block symbol-table constant) + (write-string (cdr (write-to-string constant 60))) + (cond ((lambda? constant) + (let ((expression (lambda-body constant))) + (if (and (compiled-code-address? expression) + (eq? (compiled-code-address->block expression) block)) + (begin + (write-string " (") + (let ((offset (compiled-code-address->offset expression))) + (let ((label + (disassembler/lookup-symbol symbol-table offset))) + (if label + (write-string label) + (write offset)))) + (write-string ")"))))) + ((compiled-code-address? constant) + (write-string " (offset ") + (write (compiled-code-address->offset constant)) + (write-string " in ") + (write (compiled-code-address->block constant)) + (write-string ")")) + (else false))) + +(define (disassembler/write-linkage-section block symbol-table index) + (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))))) + +(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 diff --git a/v8/src/compiler/machines/i386/dassm2.scm b/v8/src/compiler/machines/i386/dassm2.scm new file mode 100644 index 000000000..85d9b865e --- /dev/null +++ b/v8/src/compiler/machines/i386/dassm2.scm @@ -0,0 +1,326 @@ +#| -*-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)) + +(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)))))))))) + +(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)) + +(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)) + + (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 diff --git a/v8/src/compiler/machines/i386/dassm3.scm b/v8/src/compiler/machines/i386/dassm3.scm new file mode 100644 index 000000000..7463e7ab6 --- /dev/null +++ b/v8/src/compiler/machines/i386/dassm3.scm @@ -0,0 +1,1001 @@ +#| -*-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)) + +;; 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))) + +(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))))) + +(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))))) + +(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)))) + +(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))))))) + +(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)))))))) + +;;; 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))))) + +(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)))))) + + + (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)))) + + (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))))))) + +(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)) + + (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))))) + +(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))) + + (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)) + + (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))) + + (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)))) + + (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 diff --git a/v8/src/compiler/machines/i386/decls.scm b/v8/src/compiler/machines/i386/decls.scm new file mode 100644 index 000000000..fe42436cb --- /dev/null +++ b/v8/src/compiler/machines/i386/decls.scm @@ -0,0 +1,624 @@ +#| -*-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)) + +(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)) + +(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))))) + +;;;; 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))))) + +;;;; File Syntaxer + +(define (syntax-files!) + (maybe-setup-source-nodes!) + (for-each + (lambda (node) + (let ((modification-time + (let ((source (modification-time node "scm")) + (binary (modification-time node "bin"))) + (if (not source) + (error "Missing source file" (source-node/filename node))) + (and binary (< source binary) binary)))) + (set-source-node/modification-time! node modification-time) + (if (not modification-time) + (begin (write-string "\nSource file newer than binary: ") + (write (source-node/filename node)))))) + source-nodes) + (if compiler:enable-integration-declarations? + (begin + (for-each + (lambda (node) + (let ((time (source-node/modification-time node))) + (if (and time + (there-exists? (source-node/dependencies node) + (lambda (node*) + (let ((newer? + (let ((time* + (source-node/modification-time node*))) + (or (not time*) + (> time* time))))) + (if newer? + (begin + (write-string "\nBinary file ") + (write (source-node/filename node)) + (write-string " newer than dependency ") + (write (source-node/filename node*)))) + newer?)))) + (set-source-node/modification-time! node false)))) + source-nodes) + (for-each + (lambda (node) + (if (not (source-node/modification-time node)) + (for-each (lambda (node*) + (if (source-node/modification-time node*) + (begin + (write-string "\nBinary file ") + (write (source-node/filename node*)) + (write-string " depends on ") + (write (source-node/filename node)))) + (set-source-node/modification-time! node* false)) + (source-node/forward-closure node)))) + source-nodes))) + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (pathname-delete! + (pathname-new-type (source-node/pathname node) "ext")))) + source-nodes/by-rank) + (write-string "\n\nBegin pass 1:") + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (source-node/syntax! node))) + source-nodes/by-rank) + (if (there-exists? source-nodes/by-rank + (lambda (node) + (and (not (source-node/modification-time node)) + (source-node/circular? node)))) + (begin + (write-string "\n\nBegin pass 2:") + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (if (source-node/circular? node) + (source-node/syntax! node) + (source-node/touch! node)))) + source-nodes/by-rank)))) + +(define (source-node/touch! node) + (with-values + (lambda () + (sf/pathname-defaulting (source-node/pathname node) "" false)) + (lambda (input-pathname bin-pathname spec-pathname) + input-pathname + (pathname-touch! bin-pathname) + (pathname-touch! (pathname-new-type bin-pathname "ext")) + (if spec-pathname (pathname-touch! spec-pathname))))) + +(define (pathname-touch! pathname) + (if (file-exists? pathname) + (begin + (write-string "\nTouch file: ") + (write (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))) + +;;;; 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))) + +;;;; 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)) + +;;;; 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)) diff --git a/v8/src/compiler/machines/i386/inerly.scm b/v8/src/compiler/machines/i386/inerly.scm new file mode 100644 index 000000000..5a9919bf9 --- /dev/null +++ b/v8/src/compiler/machines/i386/inerly.scm @@ -0,0 +1,76 @@ +#| -*-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)) + +;;;; 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 diff --git a/v8/src/compiler/machines/i386/insmac.scm b/v8/src/compiler/machines/i386/insmac.scm new file mode 100644 index 000000000..0148218a2 --- /dev/null +++ b/v8/src/compiler/machines/i386/insmac.scm @@ -0,0 +1,208 @@ +#| -*-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)) + +;;;; 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)))))))) + +;; *** 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)) + +(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 diff --git a/v8/src/compiler/machines/i386/instr1.scm b/v8/src/compiler/machines/i386/instr1.scm new file mode 100644 index 000000000..2d6c3309a --- /dev/null +++ b/v8/src/compiler/machines/i386/instr1.scm @@ -0,0 +1,545 @@ +#| -*-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)) + +;; 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)))) + +;;;; 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))) + + ((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)) + +(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) + +(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)) + + ((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)))))) + + (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)) + + ((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 diff --git a/v8/src/compiler/machines/i386/instr2.scm b/v8/src/compiler/machines/i386/instr2.scm new file mode 100644 index 000000000..51d5aeaf0 --- /dev/null +++ b/v8/src/compiler/machines/i386/instr2.scm @@ -0,0 +1,574 @@ +#| -*-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)))) + +;;;; 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)) + +(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))) + + (((? 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)))) + +(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) + +(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) + +(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)) + +(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)) + +(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)))) + +(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) + +;;;; 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 diff --git a/v8/src/compiler/machines/i386/instrf.scm b/v8/src/compiler/machines/i386/instrf.scm new file mode 100644 index 000000000..cdf22bf25 --- /dev/null +++ b/v8/src/compiler/machines/i386/instrf.scm @@ -0,0 +1,314 @@ +#| -*-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)) + +(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)) + +(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 diff --git a/v8/src/compiler/machines/i386/insutl.scm b/v8/src/compiler/machines/i386/insutl.scm new file mode 100644 index 000000000..78e8b7f4c --- /dev/null +++ b/v8/src/compiler/machines/i386/insutl.scm @@ -0,0 +1,210 @@ +#| -*-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)) + +;;;; 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)) + + ((@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))) + +(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 diff --git a/v8/src/compiler/machines/i386/lapgen.scm b/v8/src/compiler/machines/i386/lapgen.scm new file mode 100644 index 000000000..eeed3d332 --- /dev/null +++ b/v8/src/compiler/machines/i386/lapgen.scm @@ -0,0 +1,679 @@ +#| -*-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)) + +;;;; 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))) + +;;;; 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)) + +;;;; 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)) + +;;;; 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))))))) + +(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)))))) + +(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)) + +(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))))) + +(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))))) + +(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))))) + +(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)))))) + +;;;; 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))) + +(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 diff --git a/v8/src/compiler/machines/i386/lapopt.scm b/v8/src/compiler/machines/i386/lapopt.scm new file mode 100644 index 000000000..9c44c8c93 --- /dev/null +++ b/v8/src/compiler/machines/i386/lapopt.scm @@ -0,0 +1,40 @@ +#| -*-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 diff --git a/v8/src/compiler/machines/i386/make.scm b/v8/src/compiler/machines/i386/make.scm new file mode 100644 index 000000000..69d20b0bf --- /dev/null +++ b/v8/src/compiler/machines/i386/make.scm @@ -0,0 +1,43 @@ +#| -*-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 diff --git a/v8/src/compiler/machines/i386/pc-make.scm b/v8/src/compiler/machines/i386/pc-make.scm new file mode 100644 index 000000000..67b9b7b75 --- /dev/null +++ b/v8/src/compiler/machines/i386/pc-make.scm @@ -0,0 +1,41 @@ +#| -*-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 diff --git a/v8/src/compiler/machines/i386/rgspcm.scm b/v8/src/compiler/machines/i386/rgspcm.scm new file mode 100644 index 000000000..b16cbf96d --- /dev/null +++ b/v8/src/compiler/machines/i386/rgspcm.scm @@ -0,0 +1,76 @@ +#| -*-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)) + +(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 diff --git a/v8/src/compiler/machines/i386/rules1.scm b/v8/src/compiler/machines/i386/rules1.scm new file mode 100644 index 000000000..01fa13594 --- /dev/null +++ b/v8/src/compiler/machines/i386/rules1.scm @@ -0,0 +1,500 @@ +#| -*-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)) + +;;;; 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))) + +(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))) + +;;;; 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)) + +;;;; 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))))) + +;;;; 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))))) + +;;;; 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)))) + +;;;; 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)) + +;;;; 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)))))) + +;;;; 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 diff --git a/v8/src/compiler/machines/i386/rules2.scm b/v8/src/compiler/machines/i386/rules2.scm new file mode 100644 index 000000000..a508b68c9 --- /dev/null +++ b/v8/src/compiler/machines/i386/rules2.scm @@ -0,0 +1,140 @@ +#| -*-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)) + +(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))))) + +(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 diff --git a/v8/src/compiler/machines/i386/rules3.scm b/v8/src/compiler/machines/i386/rules3.scm new file mode 100644 index 000000000..0a6820885 --- /dev/null +++ b/v8/src/compiler/machines/i386/rules3.scm @@ -0,0 +1,814 @@ +#| -*-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)) + +;;;; 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)))) + +(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)))) + +(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))))))))) + +(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)) + +(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)))))) + +;;;; 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)) + +;;;; 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))) + +;;;; 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 )) + (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)))))) + +(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))))) + +;;;; 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)))))) + +(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)))))) + +(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)))) + +;; 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)))) + +;;; Local Variables: *** +;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** +;;; End: *** diff --git a/v8/src/compiler/machines/i386/rules4.scm b/v8/src/compiler/machines/i386/rules4.scm new file mode 100644 index 000000000..ebf54eead --- /dev/null +++ b/v8/src/compiler/machines/i386/rules4.scm @@ -0,0 +1,148 @@ +#| -*-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)) + +;;;; 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)))) + +;;;; 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)))) + +(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 diff --git a/v8/src/compiler/machines/i386/rulfix.scm b/v8/src/compiler/machines/i386/rulfix.scm new file mode 100644 index 000000000..fb240e783 --- /dev/null +++ b/v8/src/compiler/machines/i386/rulfix.scm @@ -0,0 +1,687 @@ +#| -*-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)) + +;;;; 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))) + +;;;; 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)))) + +;;;; 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))))) + +(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)) + +;;;; 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)))))) + +;;;; 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))) + +(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?)))) + +;;;; 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))))))))))) + +(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)))) + +(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)))))))) + +(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))))) + +(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 diff --git a/v8/src/compiler/machines/i386/rulflo.scm b/v8/src/compiler/machines/i386/rulflo.scm new file mode 100644 index 000000000..4905c93ad --- /dev/null +++ b/v8/src/compiler/machines/i386/rulflo.scm @@ -0,0 +1,659 @@ +#| -*-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)) + +;; **** +;; 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)) + +;;;; 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)))) + +;;;; 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) + +;; 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 + )))) + +(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))))) + +(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))) + +(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))))))) + +(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)) + +;;;; 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)) + +(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 diff --git a/v8/src/compiler/machines/i386/rulrew.scm b/v8/src/compiler/machines/i386/rulrew.scm new file mode 100644 index 000000000..cf4766309 --- /dev/null +++ b/v8/src/compiler/machines/i386/rulrew.scm @@ -0,0 +1,379 @@ +#| -*-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)) + +;;;; 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)))) + +;;; 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))) + +;;;; 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))))))) + +(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)) + +#| +;; 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.)) + +;;;; 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))))) + +