#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/assmd.scm,v 4.5 1989/05/17 20:27:46 jinx Rel $
-$MC68020-Header: assmd.scm,v 1.35 88/08/31 05:55:31 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/assmd.scm,v 4.6 1991/02/15 00:40:59 jinx Exp $
+$MC68020-Header: assmd.scm,v 1.36 89/08/28 18:33:33 GMT cph Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
-(let-syntax ((fold
- (macro (expression)
- (eval expression system-global-environment))))
-
-(define-integrable addressing-granularity 8)
-(define-integrable scheme-object-width 32)
-(define-integrable endianness 'LITTLE)
+(let-syntax ((ucode-type (macro (name) `',(microcode-type name))))
(define-integrable maximum-padding-length
;; Instructions can be any number of bytes long.
(define-integrable padding-string
;; Pad with HALT instructions
- (fold (unsigned-integer->bit-string 8 #x00)))
+ (unsigned-integer->bit-string 8 #x00))
(define-integrable block-offset-width
;; Block offsets are encoded words
16)
(define maximum-block-offset
- (fold (- (expt 2 15) 1)))
+ (- (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
- (fold (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR))))
+ (unsigned-integer->bit-string scheme-type-width
+ (ucode-type manifest-nm-vector)))
(define (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string 24 n) nmv-type-string))
-
-(define (object->bit-string object)
- (bit-string-append
- (unsigned-integer->bit-string 24 (primitive-datum object))
- (unsigned-integer->bit-string 8 (primitive-type object))))
+ (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
+ nmv-type-string))
;;; Machine dependent instruction order
-(define-integrable (instruction-initial-position block)
- block ; ignored
- 0)
-
(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-append
- bit-string-append)
+(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
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/compiler.cbf,v 1.3 1989/07/11 23:52:21 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/compiler.cbf,v 1.4 1991/02/15 00:41:03 jinx Exp $
-Copyright (c) 1989 Massachusetts Institute of Technology
+Copyright (c) 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Compiler Recompiling script
-\f
-((access compiler:batch-compile (->environment '(compiler top-level)))
- '(
- "back/asmmac"
- "back/bittop"
- "back/bitutl"
- "back/insseq"
- "back/lapgn1"
- "back/lapgn2"
- "back/lapgn3"
- "back/linear"
- "back/mermap"
- "back/regmap"
- "back/syerly"
- "back/symtab"
- "back/syntax"
- "base/blocks"
- "base/btree"
- "base/cfg1"
- "base/cfg2"
- "base/cfg3"
- "base/constr"
- "base/contin"
- "base/crstop"
- "base/ctypes"
- "base/debug"
- "base/enumer"
- "base/hashtb"
- "base/infnew"
- "base/infutl"
- "base/lvalue"
- "base/macros"
- "base/mvalue"
- "base/object"
- "base/pmerly"
- "base/pmlook"
- "base/pmpars"
- "base/proced"
- "base/refctx"
- "base/rvalue"
- "base/scode"
- "base/sets"
- "base/subprb"
- "base/switch"
- "base/toplev"
- "base/utils"
- "fggen/canon"
- "fggen/declar"
- "fggen/fggen"
- "fgopt/blktyp"
- "fgopt/closan"
- "fgopt/conect"
- "fgopt/contan"
- "fgopt/delint"
- "fgopt/desenv"
- "fgopt/envopt"
- "fgopt/folcon"
- "fgopt/offset"
- "fgopt/operan"
- "fgopt/order"
- "fgopt/outer"
- "fgopt/param"
- "fgopt/reord"
- "fgopt/reuse"
- "fgopt/sideff"
- "fgopt/simapp"
- "fgopt/simple"
- "fgopt/subfre"
- "rtlbase/regset"
- "rtlbase/rgraph"
- "rtlbase/rtlcfg"
- "rtlbase/rtlcon"
- "rtlbase/rtlexp"
- "rtlbase/rtline"
- "rtlbase/rtlobj"
- "rtlbase/rtlreg"
- "rtlbase/rtlty1"
- "rtlbase/rtlty2"
- "rtlgen/fndblk"
- "rtlgen/fndvar"
- "rtlgen/opncod"
- "rtlgen/rgcomb"
- "rtlgen/rgproc"
- "rtlgen/rgretn"
- "rtlgen/rgrval"
- "rtlgen/rgstmt"
- "rtlgen/rtlgen"
- "rtlopt/ralloc"
- "rtlopt/rcse1"
- "rtlopt/rcse2"
- "rtlopt/rcseep"
- "rtlopt/rcseht"
- "rtlopt/rcserq"
- "rtlopt/rcsesr"
- "rtlopt/rdeath"
- "rtlopt/rdebug"
- "rtlopt/rinvex"
- "rtlopt/rlife"
- "vax/assmd"
- "vax/coerce"
- "vax/dassm1"
- "vax/dassm2"
- "vax/dassm3"
- "vax/decls"
- "vax/dinstr1"
- "vax/dinstr2"
- "vax/dinstr3"
- "vax/dsyn"
- "vax/inerly"
- "vax/insmac"
- "vax/instr1"
- "vax/instr2"
- "vax/instr3"
- "vax/insutl"
- "vax/lapgen"
- "vax/machin"
- ;; "vax/make"
- "vax/rgspcm"
- "vax/rules1"
- "vax/rules2"
- "vax/rules3"
- "vax/rules4"
- "vax/rulfix"
- ))
\ No newline at end of file
+;;;; Script to incrementally compile the compiler (from .bins)
+
+(for-each compile-directory
+ '("back"
+ "base"
+ "fggen"
+ "fgopt"
+ "machines/vax"
+ "rtlbase"
+ "rtlgen"
+ "rtlopt"))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/compiler.pkg,v 1.5 1989/07/11 23:48:53 cph Rel $
-$MC68020-Header: comp.pkg,v 1.22.1.1 89/05/21 14:45:10 GMT jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/compiler.pkg,v 1.6 1991/02/15 00:41:07 jinx Exp $
+$MC68020-Header: comp.pkg,v 1.30 90/05/03 15:16:59 GMT jinx Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
"rtlbase/rtlcfg" ;RTL: CFG types
"rtlbase/rtlobj" ;RTL: CFG objects
"rtlbase/regset" ;RTL: register sets
+ "rtlbase/valclass" ;RTL: value classes
"back/insseq" ;LAP instruction sequences
)
compiler:analyze-side-effects?
compiler:cache-free-variables?
compiler:code-compression?
+ compiler:compile-by-procedures?
compiler:cse?
compiler:default-top-level-declarations
compiler:enable-expansion-declarations?
compiler:enable-integration-declarations?
+ compiler:generate-lap-files?
compiler:generate-range-checks?
compiler:generate-rtl-files?
compiler:generate-type-checks?
compiler:implicit-self-static?
+ compiler:noisy?
compiler:open-code-flonum-checks?
compiler:open-code-primitives?
compiler:optimize-environments?
compiler:package-optimization-level
compiler:preserve-data-structures?
- compiler:show-subphases?))
+ compiler:show-phases?
+ compiler:show-procedures?
+ compiler:show-subphases?
+ compiler:show-time-reports?
+ compiler:use-multiclosures?))
\f
(define-package (compiler reference-contexts)
(files "base/refctx")
*rtl-graphs*
*rtl-procedures*)
(export (compiler lap-syntaxer)
- compiler:external-labels
+ *block-label*
+ *external-labels*
label->object)
(export (compiler debug)
*root-expression*
*rtl-procedures*
*rtl-graphs*)
(import (runtime compiler-info)
- make-dbg-info-vector))
+ make-dbg-info-vector)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
\f
(define-package (compiler debug)
(files "base/debug")
(parent (compiler))
(export ()
- compiler:write-rtl-file
debug/find-continuation
debug/find-entry-node
debug/find-procedure
show-bblock-rtl
show-fg
show-fg-node
- show-rtl)
+ show-rtl
+ write-rtl-instructions)
(import (runtime pretty-printer)
- *pp-primitives-by-name*))
+ *pp-primitives-by-name*)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
dbg-block-name/return-address
dbg-block-name/static-link
- make-dbg-label
- dbg-label/names
- set-dbg-label/names!
+ make-dbg-label-2
dbg-label/offset
- set-dbg-label/name!
set-dbg-label/external?!))
(define-package (compiler constraints)
(parent (compiler fg-optimizer))
(export (compiler top-level) operator-analysis))
+(define-package (compiler fg-optimizer variable-indirection)
+ (files "fgopt/varind")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) initialize-variable-indirections!))
+
(define-package (compiler fg-optimizer environment-optimization)
(files "fgopt/envopt")
(parent (compiler fg-optimizer))
(define-package (compiler fg-optimizer continuation-analysis)
(files "fgopt/contan")
(parent (compiler fg-optimizer))
- (export (compiler top-level) continuation-analysis))
+ (export (compiler top-level)
+ continuation-analysis
+ setup-block-static-links!))
(define-package (compiler fg-optimizer compute-node-offsets)
(files "fgopt/offset")
(parent (compiler fg-optimizer))
(export (compiler top-level)
setup-block-types!
- setup-closure-contexts!))
+ setup-closure-contexts!)
+ (export (compiler)
+ indirection-block-procedure))
(define-package (compiler fg-optimizer simplicity-analysis)
(files "fgopt/simple")
(parent (compiler fg-optimizer subproblem-ordering))
(export (compiler fg-optimizer subproblem-ordering)
parameter-analysis))
+
+(define-package (compiler fg-optimizer return-equivalencing)
+ (files "fgopt/reteqv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) find-equivalent-returns!))
\f
(define-package (compiler rtl-generator)
(files "rtlgen/rtlgen" ;RTL generator
(files "rtlgen/opncod")
(parent (compiler rtl-generator))
(export (compiler rtl-generator) combination/inline)
- (export (compiler fg-optimizer simplicity-analysis)
- combination/inline/simple?)
- (export (compiler fg-optimizer subproblem-ordering parameter-analysis)
- combination/inline/simple?)
(export (compiler top-level) open-coding-analysis))
(define-package (compiler rtl-generator find-block)
(export (compiler rtl-generator)
generate/rvalue
load-closure-environment
+ make-cons-closure-indirection
+ make-cons-closure-redirection
+ make-closure-redirection
make-ic-cons
make-non-trivial-closure-cons
- make-trivial-closure-cons))
+ make-trivial-closure-cons
+ redirect-closure))
(define-package (compiler rtl-generator generate/combination)
(files "rtlgen/rgcomb")
(parent (compiler rtl-generator))
(export (compiler rtl-generator)
- generate/combination))
+ generate/combination)
+ (export (compiler rtl-generator combination/inline)
+ generate/invocation-prefix))
(define-package (compiler rtl-generator generate/return)
(files "rtlgen/rgretn")
(parent (compiler rtl-optimizer))
(export (compiler top-level) invertible-expression-elimination))
+(define-package (compiler rtl-optimizer common-suffix-merging)
+ (files "rtlopt/rtlcsm")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) merge-common-suffixes!))
+
+(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
+ (files "rtlopt/rdflow")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) rtl-dataflow-analysis))
+
+(define-package (compiler rtl-optimizer rtl-rewriting)
+ (files "rtlopt/rerite")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level)
+ rtl-rewriting:post-cse
+ rtl-rewriting:pre-cse)
+ (export (compiler lap-syntaxer) add-rewriting-rule!))
+
(define-package (compiler rtl-optimizer lifetime-analysis)
(files "rtlopt/rlife")
(parent (compiler rtl-optimizer))
(export (compiler rtl-optimizer code-compression) mark-set-registers!))
(define-package (compiler rtl-optimizer code-compression)
- (files "rtlopt/rdeath")
+ (files "rtlopt/rcompr")
(parent (compiler rtl-optimizer))
(export (compiler top-level) code-compression))
"machines/vax/rules3" ; " " "
"machines/vax/rules4" ; " " "
"machines/vax/rulfix" ;code generation rules: fixnums
+ "machines/vax/rulrew" ;code rewriting rules
"back/syntax" ;Generic syntax phase
"back/syerly" ;Early binding version
"machines/vax/coerce" ;Coercions: integer -> bit string
lap:make-unconditional-branch
lap:syntax-instruction)
(export (compiler top-level)
- generate-bits)
+ *interned-assignments*
+ *interned-constants*
+ *interned-uuo-links*
+ *interned-variables*
+ *next-constant*
+ generate-lap)
(import (scode-optimizer expansion)
scode->scode-expander))
(files "back/linear")
(parent (compiler lap-syntaxer))
(export (compiler lap-syntaxer)
- linearize-bits
- bblock-linearize-bits)
+ linearize-lap
+ bblock-linearize-lap)
(export (compiler top-level)
- linearize-bits))
+ linearize-lap))
(define-package (compiler assembler)
(files "machines/vax/assmd" ;Machine dependent
compiler:disassemble)
(import (runtime compiler-info)
compiled-code-block/dbg-info
- dbg-info-vector/items
+ dbg-info-vector/blocks-vector
dbg-info-vector?
dbg-info/labels
dbg-label/external?
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/compiler.sf,v 1.2 1989/07/11 23:51:35 cph Rel $
-$MC68020-Header: comp.sf,v 1.7 88/12/15 17:02:14 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/compiler.sf,v 1.3 1991/02/15 00:41:12 jinx Exp $
+$MC68020-Header: comp.sf,v 1.12 90/01/18 22:43:26 GMT cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(if (not (name->package '(COMPILER)))
(begin
;; If there is no existing package constructor, generate one.
- (if (not (file-exists? "machines/vax/comp.bcon"))
+ (if (not (file-exists? "comp.bcon"))
(begin
((access cref/generate-trivial-constructor
(->environment '(CROSS-REFERENCE)))
- "machines/vax/comp")
- (sf "machines/vax/comp.con" "comp.bcon")))
- (load "machines/vax/comp.bcon")))
+ "comp")
+ (sf "comp.con" "comp.bcon")))
+ (load "comp.bcon")))
;; Guarantee that the necessary syntactic transforms and optimizers
;; are loaded.
((access initialize-package! environment)))
(sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
(sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
- (sf-and-load '("machines/vax/assmd") '(COMPILER ASSEMBLER))
+ (fluid-let ((sf/default-syntax-table
+ (access compiler-syntax-table
+ (->environment '(COMPILER MACROS)))))
+ (sf-and-load '("machines/vax/machin") '(COMPILER)))
+ (fluid-let ((sf/default-declarations
+ '((integrate-external "insseq")
+ (integrate-external "machin")
+ (usual-definition (set expt)))))
+ (sf-and-load '("machines/vax/assmd") '(COMPILER ASSEMBLER)))
(sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
(sf-and-load '("machines/vax/coerce" "back/asmmac"
"machines/vax/insmac")
(in-package (->environment '(COMPILER LAP-SYNTAXER))
(if (and compiler:enable-expansion-declarations?
(null? early-instructions))
- (fluid-let ((load-noisily? false))
+ (fluid-let ((load-noisily? false)
+ (load/suppress-loading-message? false))
+ (write-string "\n\n---- Pre-loading instruction sets ----")
(for-each (lambda (name)
- (write-string "\nPre-loading instruction set from ")
- (write name)
(load (string-append "machines/vax/" name ".scm")
'(COMPILER LAP-SYNTAXER)
- early-syntax-table)
- (write-string " -- done"))
+ early-syntax-table))
'("insutl" "instr1" "instr2" "instr3")))))
;; Resyntax any files that need it.
((access syntax-files! (->environment '(COMPILER))))
+;; Rebuild the package constructors and cref.
(cref/generate-all "comp")
-
(sf "comp.con" "comp.bcon")
(sf "comp.ldr" "comp.bldr")
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm1.scm,v 4.4 1989/06/07 02:14:22 jinx Rel $
-$MC68020-Header: dassm1.scm,v 4.10 88/12/30 07:05:04 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm1.scm,v 4.5 1991/02/15 00:41:16 jinx Exp $
+$MC68020-Header: dassm1.scm,v 4.15 90/07/12 16:42:39 GMT jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(let ((pathname (->pathname filename)))
(with-output-to-file (pathname-new-type pathname "lap")
(lambda ()
- (let ((object (fasload (pathname-new-type pathname "com")))
- (info (let ((pathname (pathname-new-type pathname "binf")))
- (and (if (default-object? symbol-table?)
- (file-exists? pathname)
- symbol-table?)
- (fasload pathname)))))
- (cond ((compiled-code-address? object)
- (disassembler/write-compiled-code-block
- (compiled-code-address->block object)
- info
- false))
- ((not (scode/comment? object))
- (error "compiler:write-lap-file : Not a compiled file"
- (pathname-new-type pathname "com")))
- (else
- (scode/comment-components
- object
- (lambda (text expression)
- expression ;; ignored
- (if (dbg-info-vector? text)
- (let ((items (dbg-info-vector/items text)))
- (for-each disassembler/write-compiled-code-block
- (vector->list items)
- (if (false? info)
- (make-list (vector-length items) false)
- (vector->list info))))
- (error "compiler:write-lap-file : Not a compiled file"
- (pathname-new-type pathname "com"))))))))))))
+ (let ((com-file (pathname-new-type pathname "com")))
+ (let ((object (fasload com-file))
+ (info
+ (let ((pathname (pathname-new-type pathname "binf")))
+ (and (if (default-object? symbol-table?)
+ (file-exists? pathname)
+ symbol-table?)
+ (fasload pathname)))))
+ (if (compiled-code-address? object)
+ (disassembler/write-compiled-code-block
+ (compiled-code-address->block object)
+ info)
+ (begin
+ (if (not
+ (and (scode/comment? object)
+ (dbg-info-vector? (scode/comment-text object))))
+ (error "Not a compiled file" com-file))
+ (let ((items
+ (vector->list
+ (dbg-info-vector/blocks-vector
+ (scode/comment-text object)))))
+ (if (not (null? items))
+ (if (false? info)
+ (let loop ((items items))
+ (disassembler/write-compiled-code-block
+ (car items)
+ false)
+ (if (not (null? (cdr items)))
+ (begin
+ (write-char #\page)
+ (loop (cdr items)))))
+ (let loop
+ ((items items) (info (vector->list info)))
+ (disassembler/write-compiled-code-block
+ (car items)
+ (car info))
+ (if (not (null? (cdr items)))
+ (begin
+ (write-char #\page)
+ (loop (cdr items) (cdr info))))))))))))))))
(define disassembler/base-address)
(define compiled-code-block/objects-per-procedure-cache)
(define compiled-code-block/objects-per-variable-cache)
-(define (write-block block)
- (write-string "#[COMPILED-CODE-BLOCK ")
- (write-string
- (number->string (object-hash block) '(HEUR (RADIX D S))))
- (write-string " ")
- (write-string
- (number->string (object-datum block) '(HEUR (RADIX X E))))
- (write-string "]"))
-
-(define (disassembler/write-compiled-code-block block info #!optional page?)
+(define (disassembler/write-compiled-code-block block info)
(let ((symbol-table (and info (dbg-info/labels info))))
- (if (or (default-object? page?) page?)
- (begin
- (write-char #\page)
- (newline)))
(write-string "Disassembly of ")
- (write-block block)
+ (write block)
(write-string ":\n")
(write-string "Code:\n\n")
(disassembler/write-instruction-stream
(fluid-let ((*unparser-radix* 16))
(disassembler/for-each-instruction instruction-stream
(lambda (offset instruction)
- (disassembler/write-instruction
- symbol-table
- offset
- (lambda ()
- (let ((string
- (with-output-to-string
- (lambda ()
- (display instruction)))))
- (string-downcase! string)
- (write-string string))))))))
+ (disassembler/write-instruction symbol-table
+ offset
+ (lambda () (display instruction)))))))
(define (disassembler/for-each-instruction instruction-stream procedure)
(let loop ((instruction-stream instruction-stream))
(let ((label
(disassembler/lookup-symbol symbol-table offset)))
(if label
- (write-string (string-downcase 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-block (compiled-code-address->block constant))
+ (write (compiled-code-address->block constant))
(write-string ")"))
(else false)))
\f
(define (disassembler/write-linkage-section block symbol-table index)
- (define (write-caches index size how-many writer)
- (let loop ((index index) (how-many how-many))
- (if (zero? how-many)
- 'DONE
- (begin
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (writer block index)))
- (loop (+ size index) (-1+ how-many))))))
-
(let* ((field (object-datum (system-vector-ref block index)))
(descriptor (integer-divide field #x10000)))
(let ((kind (integer-divide-quotient descriptor))
(length (integer-divide-remainder descriptor)))
+
+ (define (write-caches size writer)
+ (let loop ((index (1+ index))
+ (how-many (quotient length 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)
(case kind
((0)
(write-caches
- (1+ index)
compiled-code-block/objects-per-procedure-cache
- (quotient length compiled-code-block/objects-per-procedure-cache)
disassembler/write-procedure-cache))
((1)
(write-caches
- (1+ index)
compiled-code-block/objects-per-variable-cache
- (quotient length compiled-code-block/objects-per-variable-cache)
- (lambda (block index)
- (disassembler/write-variable-cache "Reference" block index))))
+ (lambda (block index)
+ (disassembler/write-variable-cache "Reference" block index))))
((2)
(write-caches
- (1+ index)
compiled-code-block/objects-per-variable-cache
- (quotient length compiled-code-block/objects-per-variable-cache)
- (lambda (block index)
- (disassembler/write-variable-cache "Assignment" block index))))
+ (lambda (block index)
+ (disassembler/write-variable-cache "Assignment" block index))))
(else
(error "disassembler/write-linkage-section: Unknown section kind"
kind)))
(if label
(begin
(write-char #\Tab)
- (write-string (string-downcase (dbg-label/name label)))
+ (write-string (dbg-label/name label))
(write-char #\:)
(newline)))))
(if disassembler/write-addresses?
(begin
(write-string
- (number->string (+ offset disassembler/base-address)
- '(HEUR (RADIX X S))))
+ (number->string (+ offset disassembler/base-address) 16))
(write-char #\Tab)))
(if disassembler/write-offsets?
(begin
- (write-string (number->string offset '(HEUR (RADIX X S))))
+ (write-string (number->string offset 16))
(write-char #\Tab)))
(if symbol-table
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm2.scm,v 4.9 1989/06/07 02:17:36 jinx Rel $
-$MC68020-Header: dassm2.scm,v 4.12 88/12/30 07:05:13 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm2.scm,v 4.10 1991/02/15 00:41:23 jinx Exp $
+$MC68020-Header: dassm2.scm,v 4.17 90/05/03 15:17:04 GMT jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; VAX Disassembler: Top Level
+;;; package: (compiler disassembler)
(declare (usual-integrations))
-
+\f
(set! compiled-code-block/bytes-per-object 4)
(set! compiled-code-block/objects-per-procedure-cache 2)
(set! compiled-code-block/objects-per-variable-cache 1)
-\f
+
(set! disassembler/read-variable-cache
(lambda (block index)
(let-syntax ((ucode-type
(lambda (block index)
(fluid-let ((*block block))
(let* ((offset (compiled-code-block/index->offset index)))
- (let ((opcode (read-unsigned-integer offset 16))
- (arity (read-unsigned-integer (+ offset 6) 16)))
+ (let ((arity (read-unsigned-integer offset 16))
+ (opcode (read-unsigned-integer (+ offset 2) 16)))
(case opcode
- ((#x9f17) ; JMP @#<value>
+ ((#x9f17) ; JMP @&<value>
+ ;; *** This should learn how to decode trampolines. ***
(vector 'COMPILED
- (read-procedure (+ offset 2))
+ (read-procedure (+ offset 4))
arity))
- ((#x9f16) ; JSB @#<value>
- (let* ((new-block
- (compiled-code-address->block
- (read-procedure (+ offset 2))))
- (offset
- (fluid-let ((*block new-block))
- (read-unsigned-integer 14 16))))
- (case offset
- ((#x106) ; lookup
- (vector 'VARIABLE
- (variable-cache-name
- (system-vector-ref new-block 3))
- arity))
- ((#x10c ; interpreted
- #x160 ; fixed arity primitive
- #x166) ; lexpr primitive
- (vector 'INTERPRETED
- (system-vector-ref new-block 3)
- arity))
- ((#x112 ; arity
- #x11e ; entity
- #x124 #x12a #x130 #x136 #x13c ; specialized arity
- #x142 #x148 #x14e #x154 #x15a)
- (vector 'COMPILED
- (system-vector-ref new-block 3)
- arity))
- (else ; including #x118, APPLY
- (error
- "disassembler/read-procedure-cache: Unknown offset"
- offset block index)))))
(else
(error "disassembler/read-procedure-cache: Unknown opcode"
opcode block index))))))))
(let ((label (dbg-labels/find-offset symbol-table offset)))
(and label
(dbg-label/name label))))))
-\f
+
(define (external-label-marker? symbol-table offset state)
(if symbol-table
(let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
(loop offset)))
(= offset
(/ (bit-string->unsigned-integer contents) 2))))))))
-
+\f
(define (make-data-deposit *ir size)
(case size
((B)
;; This assumes that pco was just extracted.
;; VAX PC relative modes are defined with respect to the pc
;; immediately after the PC relative field.
+
+ (define (default)
+ `(,(if deferred? '@@PCO '@PCO) ,size ,pco))
+
+ (define (test address)
+ (disassembler/lookup-symbol *symbol-table address))
+
+ (define (object-offset? relative)
+ (let* ((unsigned (if (negative? relative)
+ (+ (expt 2 32) relative)
+ relative))
+ (tc (quotient unsigned (expt 2 scheme-datum-width))))
+
+ (define (try tc)
+ (let* ((object-base (* tc (expt 2 scheme-datum-width)))
+ (offset (- unsigned object-base)))
+ (cond ((test (+ *current-offset offset))
+ =>
+ (lambda (label)
+ (list label object-base)))
+ (else
+ false))))
+
+ (or (try tc)
+ (try (1+ tc)))))
+
(let ((absolute (+ pco *current-offset)))
- (if disassembler/symbolize-output?
- (let ((answ (disassembler/lookup-symbol *symbol-table absolute)))
- (if answ
- `(,(if deferred? '@@PCR '@PCR) ,answ)
- `(,(if deferred? '@@PCO '@PCO) ,size ,pco)))
- `(,(if deferred? '@@PCO '@PCO) ,size ,pco))))
+ (cond ((not disassembler/symbolize-output?)
+ (default))
+ ((test absolute)
+ =>
+ (lambda (answ)
+ `(,(if deferred? '@@PCR '@PCR) ,answ)))
+ ((test (- absolute 2))
+ ;; Kludge to get branches to execute caches correctly.
+ =>
+ (lambda (answ)
+ `(,(if deferred? '@@PCRO '@PCRO) ,answ 2)))
+ ((object-offset? pco)
+ =>
+ (lambda (answ)
+ `(,(if deferred? '@@PCRO '@PCRO) ,@answ)))
+ (else
+ (default)))))
(define (undefined-instruction)
;; This losing assignment removes a 'cwcc'. Too bad.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/decls.scm,v 4.4 1989/05/21 17:56:33 jinx Rel $
-$MC68020-Header: decls.scm,v 4.21.1.1 89/05/21 14:50:15 GMT jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/decls.scm,v 4.5 1991/02/15 00:41:29 jinx Exp $
+$MC68020-Header: decls.scm,v 4.27 90/05/03 15:17:08 GMT jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Compiler File Dependencies. VAX compiler.
+;;;; Compiler File Dependencies. VAX version.
+;;; package: (compiler declarations)
(declare (usual-integrations))
\f
filenames))))
(file-dependency/syntax/join
(append (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3" "constr" "contin"
- "crstop" "ctypes" "debug" "enumer" "infnew"
- "lvalue" "object" "pmerly" "proced" "refctx"
- "rvalue" "scode" "sets" "subprb" "switch"
- "toplev" "utils")
+ "blocks" "cfg1" "cfg2" "cfg3" "constr"
+ "contin" "crstop" "ctypes" "debug" "enumer"
+ "infnew" "lvalue" "object" "pmerly" "proced"
+ "refctx" "rvalue" "scode" "sets" "subprb"
+ "switch" "toplev" "utils")
(filename/append "back"
"asmmac" "bittop" "bitutl" "insseq" "lapgn1"
"lapgn2" "lapgn3" "linear" "regmap" "symtab"
"syntax")
(filename/append "machines/vax"
- "dassm1" "dsyn" "insmac" "machin" "rgspcm")
+ "dassm1" "dsyn" "insmac" "machin" "rgspcm"
+ "rulrew")
(filename/append "fggen"
"declar" "fggen" "canon")
(filename/append "fgopt"
"blktyp" "closan" "conect" "contan" "delint"
"desenv" "envopt" "folcon" "offset" "operan"
- "order" "outer" "param" "reord" "reuse"
- "sideff" "simapp" "simple" "subfre")
+ "order" "outer" "param" "reord" "reteqv" "reuse"
+ "sideff" "simapp" "simple" "subfre" "varind")
(filename/append "rtlbase"
"regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
- "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2")
+ "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
+ "valclass")
(filename/append "rtlgen"
"fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
"rgretn" "rgrval" "rgstmt" "rtlgen")
(filename/append "rtlopt"
- "ralloc" "rcse1" "rcse2" "rcseep" "rcseht"
- "rcserq" "rcsesr" "rdeath" "rdebug" "rinvex"
- "rlife"))
+ "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
+ "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
+ "rerite" "rinvex" "rlife" "rtlcsm"))
compiler-syntax-table)
(file-dependency/syntax/join
(filename/append "machines/vax"
;;;; Integration Dependencies
(define (initialize/integration-dependencies!)
- (let ((front-end-base
+
+ (define (add-declaration! declaration filenames)
+ (for-each (lambda (filenames)
+ (let ((node (filename->source-node filenames)))
+ (set-source-node/declarations!
+ node
+ (cons declaration
+ (source-node/declarations node)))))
+ filenames))
+
+ (let* ((front-end-base
(filename/append "base"
"blocks" "cfg1" "cfg2" "cfg3"
"contin" "ctypes" "enumer" "lvalue"
(filename/append "machines/vax" "machin"))
(rtl-base
(filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlexp" "rtlobj"
- "rtlreg" "rtlty1" "rtlty2"))
+ "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
+ "rtlty2"))
(cse-base
(filename/append "rtlopt"
- "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr"))
+ "rcse1" "rcseht" "rcserq" "rcsesr"))
+ (cse-all
+ (append (filename/append "rtlopt"
+ "rcse2" "rcseep")
+ cse-base))
(instruction-base
- (append (filename/append "back" "insseq")
- (filename/append "machines/vax" "assmd" "machin")))
+ (filename/append "machines/vax" "assmd" "machin"))
(lapgen-base
- (append (filename/append "back" "lapgn2" "lapgn3" "regmap")
+ (append (filename/append "back" "lapgn3" "regmap")
(filename/append "machines/vax" "lapgen")))
(assembler-base
- (append (filename/append "back" "bitutl" "symtab")
+ (append (filename/append "back" "symtab")
(filename/append "machines/vax" "insutl")))
(lapgen-body
(append
- (filename/append "back" "lapgn1" "syntax")
+ (filename/append "back" "lapgn1" "lapgn2" "syntax")
(filename/append "machines/vax"
"rules1" "rules2" "rules3" "rules4" "rulfix")))
(assembler-body
(define-integration-dependencies "machines/vax" "machin" "rtlbase"
"rtlreg" "rtlty1" "rtlty2")
- (define-integration-dependencies "rtlbase" "regset" "base")
(define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
(define-integration-dependencies "rtlbase" "rgraph" "machines/vax"
"machin")
(define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
(define-integration-dependencies "rtlbase" "rtlcon" "machines/vax"
"machin")
- (define-integration-dependencies "rtlbase" "rtlexp" "base" "utils")
- (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" "rtlreg")
+ (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
+ "rtlreg" "rtlty1")
(define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
(define-integration-dependencies "rtlbase" "rtline" "rtlbase"
"rtlcfg" "rtlty2")
(filename/append "fgopt"
"blktyp" "closan" "conect" "contan" "delint" "desenv"
"envopt" "folcon" "offset" "operan" "order" "param"
- "outer" "reuse" "sideff" "simapp" "simple" "subfre"))
+ "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
+ "subfre" "varind"))
(append vax-base front-end-base))
(define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
(append vax-base front-end-base rtl-base))
(file-dependency/integration/join
- (append cse-base
- (filename/append "rtlopt" "ralloc" "rdeath" "rdebug" "rinvex"
- "rlife"))
+ (append cse-all
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
+ "rerite" "rinvex" "rlife" "rtlcsm")
+ (filename/append "machines/vax" "rulrew"))
(append vax-base rtl-base))
- (file-dependency/integration/join cse-base cse-base)
+ (file-dependency/integration/join cse-all cse-base)
- (define-integration-dependencies "rtlopt" "rcseht" "base" "object")
- (define-integration-dependencies "rtlopt" "rcserq" "base" "object")
- (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
+ (filename/append "rtlbase" "regset"))
(file-dependency/integration/join
- (append instruction-base
- lapgen-base
- lapgen-body
- assembler-base
- assembler-body
- (filename/append "back" "linear" "syerly"))
- instruction-base)
+ (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)
(define-integration-dependencies "back" "lapgn1" "base"
"cfg1" "cfg2" "utils")
(define-integration-dependencies "back" "lapgn1" "rtlbase"
- "regset" "rgraph" "rtlcfg")
+ "rgraph" "rtlcfg")
(define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
(define-integration-dependencies "back" "lapgn3" "rtlbase" "rtlcfg")
(define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dsyn.scm,v 1.6 1989/05/17 20:28:51 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dsyn.scm,v 1.7 1991/02/15 00:41:35 jinx Exp $
This file has no counterpart in the MC68020 compiler
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
(make-syntax-table system-global-syntax-table))
(define transform/define-instruction
- (macro (name . cases)
+ (macro (name . patterns)
(if (memq name instructions-disassembled-specially)
''()
- `(begin ,@(map (lambda (case)
- (process-instruction-definition name case))
- cases)))))
-
-(define (process-instruction-definition name case)
- (let ((prefix (cons name (find-pattern-prefix (car case))))
- (opcode-field (cadr case))
- (operands (cddr case)))
+ `(begin ,@(map (lambda (pattern)
+ (process-instruction-definition name pattern))
+ patterns)))))
+
+(define (process-instruction-definition name pattern)
+ (let ((prefix (cons name (find-pattern-prefix (car pattern))))
+ (opcode-field (cadr pattern))
+ (operands (cddr pattern)))
(if (not (eq? (car opcode-field) 'BYTE))
(error "process-instruciton-definition: unhandled opcode kind"
opcode-field))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/instr3.scm,v 1.8 1989/05/17 20:30:03 jinx Rel $
-$MC68020-Header: instr3.scm,v 1.16 88/10/04 23:04:57 GMT jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/instr3.scm,v 1.9 1991/02/15 00:41:40 jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
((define-field-instruction
(macro (name suffix1 suffix2 opcode mode)
`(define-instruction ,name
- ((,suffix1 (? pos ea-r-l) (? size ea-r-b) (? base ea-v-b) (? dst ,mode))
+ ((,suffix1 (? pos ea-r-l) (? size ea-r-b) (? base ea-v-b)
+ (? dst ,mode))
(BYTE (8 ,opcode))
(OPERAND L pos)
(OPERAND B size)
(OPERAND B base)
(OPERAND L dst))
- ((,suffix2 (? pos ea-r-l) (? size ea-r-b) (? base ea-v-b) (? dst ,mode))
+ ((,suffix2 (? pos ea-r-l) (? size ea-r-b) (? base ea-v-b)
+ (? dst ,mode))
(BYTE (8 ,(1+ opcode)))
(OPERAND L pos)
(OPERAND B size)
(define-instruction B
((B (? c cc) (@PCO (? dest)))
- (BYTE (4 c)
- (4 #x1))
+ (BYTE (4 c) (4 #x1))
(DISPLACEMENT (8 dest)))
((B (? c cc) (@PCR (? dest)))
- (BYTE (4 c)
- (4 #x1))
+ (BYTE (4 c) (4 #x1))
(DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
((W (? c inverse-cc) (@PCO (? dest)))
- (BYTE (4 c) ; (B B (~ cc) (+ *PC* 3))
- (4 #x1))
+ (BYTE (4 c) (4 #x1)) ; (B B (~ cc) (+ *PC* 3))
(BYTE (8 #x03 SIGNED))
(BYTE (8 #x31)) ; (BR W dest)
(DISPLACEMENT (16 dest)))
((W (? c inverse-cc) (@PCR (? dest)))
- (BYTE (4 c) ; (B B (~ cc) (+ *PC* 3))
- (4 #x1))
+ (BYTE (4 c) (4 #x1)) ; (B B (~ cc) (+ *PC* 3))
(BYTE (8 #x03 SIGNED))
(BYTE (8 #x31)) ; (BR W dest)
(DISPLACEMENT (16 `(- ,dest (+ *PC* 2)))))
(VARIABLE-WIDTH
(disp `(- ,label (+ *PC* 2)))
((-128 127)
- (BYTE (4 c)
- (4 #x1))
+ (BYTE (4 c) (4 #x1))
(BYTE (8 disp SIGNED)))
- ;; The following range is correct. Think about it.
((-32765 32770)
- (BYTE (4 (inverse-cc cs)) ; (B B (~ cc) (+ *PC* 3))
- (4 #x1))
+ (BYTE (4 (inverse-cc cs)) (4 #x1)) ; (B B (~ cc) (+ *PC* 3))
(BYTE (8 #x03))
(BYTE (8 #x31)) ; (BR W label)
(BYTE (16 (- disp 3) SIGNED)))
((() ())
- (BYTE (4 (inverse-cc cs)) ; (B B (~ cc) (+ *PC* 6))
- (4 #x1))
+ (BYTE (4 (inverse-cc cs)) (4 #x1)) ; (B B (~ cc) (+ *PC* 6))
(BYTE (8 #x06))
(BYTE (8 #x17)) ; (JMP (@PCO L label))
- (BYTE (4 15)
- (4 14))
+ (BYTE (4 15) (4 14))
+ (BYTE (32 (- disp 6) SIGNED)))))
+
+ (((? c cc cs) (@PCRO (? label) (? offset))) ; Kludge!
+ (VARIABLE-WIDTH
+ (disp `(+ ,offset (- ,label (+ *PC* 2))))
+ ((-128 127)
+ (BYTE (4 c) (4 #x1))
+ (BYTE (8 disp SIGNED)))
+ ((-32765 32770)
+ (BYTE (4 (inverse-cc cs)) (4 #x1)) ; (B B (~ cc) (+ *PC* 3))
+ (BYTE (8 #x03))
+ (BYTE (8 #x31)) ; (BR W label)
+ (BYTE (16 (- disp 3) SIGNED)))
+ ((() ())
+ (BYTE (4 (inverse-cc cs)) (4 #x1)) ; (B B (~ cc) (+ *PC* 6))
+ (BYTE (8 #x06))
+ (BYTE (8 #x17)) ; (JMP (@PCO L label))
+ (BYTE (4 15) (4 14))
(BYTE (32 (- disp 6) SIGNED))))))
\f
(let-syntax
((-128 127) ; (BR/BSB B label)
(BYTE (8 ,(+ #x10 bit)))
(BYTE (8 disp SIGNED)))
- ;; The following range is correct. Think about it.
+ ((-32767 32768) ; (BR/BSB W label)
+ (BYTE (8 ,(+ #x30 bit)))
+ (BYTE (16 (- disp 1) SIGNED)))
+ ((() ()) ; (JMP/JSB (@PCO L label))
+ (BYTE (8 ,(+ #x16 bit)))
+ (BYTE (4 15)
+ (4 14))
+ (BYTE (32 (- disp 4) SIGNED)))))
+
+ (((@PCRO (? label) (? offset))) ; Kludge!
+ (VARIABLE-WIDTH
+ (disp `(+ ,offset (- ,label (+ *PC* 2))))
+ ((-128 127) ; (BR/BSB B label)
+ (BYTE (8 ,(+ #x10 bit)))
+ (BYTE (8 disp SIGNED)))
((-32767 32768) ; (BR/BSB W label)
(BYTE (8 ,(+ #x30 bit)))
(BYTE (16 (- disp 1) SIGNED)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/insutl.scm,v 4.2 1989/05/17 20:30:11 jinx Rel $
-$MC68020-Header: insutl.scm,v 1.6 88/06/14 08:47:30 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/insutl.scm,v 4.3 1991/02/15 00:41:48 jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; VAX utility procedures
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(4 14))
(BYTE (32 off SIGNED)))
+ ((@RO UL (? n) (? off)) ; Kludge
+ (R M W A V I)
+ (BYTE (4 n)
+ (4 14))
+ (BYTE (32 off UNSIGNED)))
+
((@@RO L (? n) (? off))
(R M W A V I)
(BYTE (4 n)
(R M W A V I)
(BYTE (4 15)
(4 8))
- (IMMEDIATE value))
+ (IMMEDIATE value SIGNED))
- ((&U (? value)) ;Kludge
+ ((&U (? value)) ; Kludge
(R M W A V I)
(BYTE (4 15)
(4 8))
(BYTE (32 off SIGNED)))
\f
;; Self adjusting modes
+ ;; The ranges seem wrong, but are correct given that disp
+ ;; must be adjusted for the longer modes.
((@PCR (? label))
(R M W A V I)
(BYTE (4 15)
(4 10))
(BYTE (8 disp SIGNED)))
- ;; The following range is correct. Think about it.
((-32767 32768) ; (@PCO W label)
(BYTE (4 15)
(4 12))
(BYTE (4 15)
(4 11))
(BYTE (8 disp SIGNED)))
- ;; The following range is correct. Think about it.
((-32767 32768) ; (@@PCO W label)
(BYTE (4 15)
(4 13))
((() ()) ; (@@PCO L label)
(BYTE (4 15)
(4 15))
- (BYTE (32 (- disp 3) SIGNED))))))
+ (BYTE (32 (- disp 3) SIGNED)))))
+
+ ((@PCRO (? label) (? offset)) ; Kludge
+ (R M W A V I)
+ (VARIABLE-WIDTH
+ (disp `(+ ,offset (- ,label (+ *PC* 2))))
+ ((-128 127) ; (@PCO B label)
+ (BYTE (4 15)
+ (4 10))
+ (BYTE (8 disp UNSIGNED)))
+ ((-32767 32768) ; (@PCO W label)
+ (BYTE (4 15)
+ (4 12))
+ (BYTE (16 (- disp 1) UNSIGNED)))
+ ((() ()) ; (@PCO L label)
+ (BYTE (4 15)
+ (4 14))
+ (BYTE (32 (- disp 3) UNSIGNED))))))
\f
;;;; Effective address processing
((B) (if unsigned? coerce-8-bit-unsigned coerce-8-bit-signed))
((W) (if unsigned? coerce-16-bit-unsigned coerce-16-bit-signed))
((L) (if unsigned? coerce-32-bit-unsigned coerce-32-bit-signed))
- ((d f g h l o q)
+ ((D F G H L O Q)
(error "coerce-to-type: Unimplemented type" type))
(else (error "coerce-to-type: Unknown type" type))))))
(define-ea-transformer ea-w-o w o)
(define-ea-transformer ea-w-q w q)
(define-ea-transformer ea-w-w w w)
-(define-ea-transformer ea-i-? i ?)
+(define-ea-transformer ea-i-? i ?)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/lapgen.scm,v 4.9 1989/12/20 22:20:15 cph Rel $
-$MC68020-Header: lapgen.scm,v 4.19 89/01/18 13:49:56 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/lapgen.scm,v 4.10 1991/02/15 00:41:54 jinx Exp $
+$MC68020-Header: lapgen.scm,v 4.39 1991/01/30 22:48:01 jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; RTL Rules for DEC VAX. Part 1
+;;;; RTL Rules for DEC VAX.
+;;; Shared utilities and exports to the rest of the compiler.
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
-;;;; Basic machine instructions
+;;;; Register-Allocator Interface
(define (reference->register-transfer source target)
(if (and (effective-address/register? source)
(LAP (MOV L ,source ,(register-reference target)))))
(define (register->register-transfer source target)
- (LAP ,(machine->machine-register source target)))
+ (LAP ,@(machine->machine-register source target)))
(define (home->register-transfer source target)
- (LAP ,(pseudo->machine-register source target)))
+ (LAP ,@(pseudo->machine-register source target)))
(define (register->home-transfer source target)
- (LAP ,(machine->pseudo-register source target)))
+ (LAP ,@(machine->pseudo-register source target)))
+
+(define-integrable (pseudo-register-home register)
+ (offset-reference regnum:regs-pointer
+ (pseudo-register-offset register)))
+
+(define-integrable (sort-machine-registers registers)
+ registers)
+
+(define available-machine-registers
+ ;; r9 is value register.
+ ;; r10 - r13 are taken up by Scheme.
+ ;; r14 is sp and r15 is pc.
+ (list r0 r1 r2 r3 r4 r5 r6 r7 r8))
+
+(define (register-types-compatible? type1 type2)
+ (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
+
+(define (register-type register)
+ ;; This will have to be changed when floating point support is added.
+ (if (or (machine-register? register)
+ (register-value-class=word? register))
+ 'GENERAL
+ (error "unable to determine register type" register)))
+
+(define register-reference
+ (let ((references (make-vector number-of-machine-registers)))
+ (let loop ((i 0))
+ (if (< i number-of-machine-registers)
+ (begin
+ (vector-set! references i (INST-EA (R ,i)))
+ (loop (1+ i)))))
+ (lambda (register)
+ (vector-ref references register))))
+
+(define mask-reference
+ (register-reference regnum:pointer-mask))
+
+(define-export (lap:make-label-statement label)
+ ;; This should use LAP rather than INST, but
+ ;; that requires changing back/linear.scm
+ (INST (LABEL ,label)))
+
+(define-export (lap:make-unconditional-branch label)
+ (LAP (BR (@PCR ,label)))) ; Unsized
+
+(define-export (lap:make-entry-point label block-start-label)
+ block-start-label
+ (LAP (ENTRY-POINT ,label)
+ ,@(make-external-label expression-code-word label)))
+\f
+;;;; Basic Machine Instructions
(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)))
-;; Pseudo registers are at negative offsets from regs-pointer,
-;; and each is two longwords long so it can hold a double float.
+(define (pseudo-float? register)
+ (and (pseudo-register? register)
+ (value-class=float? (pseudo-register-value-class register))))
-(define-integrable (pseudo-register-offset register)
- (* -2 (1+ (register-renumber register))))
-
-(define-integrable (pseudo-register-home register)
- (offset-reference regnum:regs-pointer
- (pseudo-register-offset register)))
+(define (pseudo-word? register)
+ (and (pseudo-register? register)
+ (value-class=word? (pseudo-register-value-class register))))
(define-integrable (machine->machine-register source target)
- (INST (MOV L
- ,(register-reference source)
- ,(register-reference target))))
+ (LAP (MOV L
+ ,(register-reference source)
+ ,(register-reference target))))
(define-integrable (machine-register->memory source target)
- (INST (MOV L
- ,(register-reference source)
- ,target)))
+ (LAP (MOV L
+ ,(register-reference source)
+ ,target)))
(define-integrable (memory->machine-register source target)
- (INST (MOV L
- ,source
- ,(register-reference target))))
+ (LAP (MOV L
+ ,source
+ ,(register-reference target))))
+
+(define (byte-offset-reference register offset)
+ (if (zero? offset)
+ (INST-EA (@R ,register))
+ (INST-EA (@RO ,(datum-size offset) ,register ,offset))))
+
+(define-integrable (offset-reference register offset)
+ (byte-offset-reference register (* 4 offset)))
+
+(define-integrable (pseudo-register-offset register)
+ ;; Offset into register block for temporary registers
+ (+ (+ (* 16 4) (* 40 8))
+ (* 2 (register-renumber register))))
(define (datum-size datum)
(cond ((<= -128 datum 127) 'B)
((<= -32768 datum 32767) 'W)
(else 'L)))
+\f
+;;;; Utilities needed by the rules files.
-(define (offset-reference register offset)
- (if (zero? offset)
- (INST-EA (@R ,register))
- (let ((real-offset (* 4 offset)))
- (INST-EA (@RO ,(datum-size real-offset) ,register ,real-offset)))))
+(define-integrable (standard-target-reference target)
+ (delete-dead-registers!)
+ (reference-target-alias! target 'GENERAL))
-(define (byte-offset-reference register offset)
- (if (zero? offset)
- (INST-EA (@R ,register))
- (INST-EA (@RO ,(datum-size offset) ,register ,offset))))
+(define-integrable (any-register-reference register)
+ (standard-register-reference register false true))
+
+(define-integrable (standard-temporary-reference)
+ (reference-temporary-register! 'GENERAL))
+
+;;; Assignments
+
+(define-integrable (convert-object/constant->register target constant
+ rtconversion
+ ctconversion)
+ (let ((target (standard-target-reference target)))
+ (if (non-pointer-object? constant)
+ (ctconversion constant target)
+ (rtconversion (constant->ea constant) target))))
+
+(define-integrable (convert-object/register->register target source conversion)
+ ;; `conversion' often expands into multiple references to `target'.
+ (with-register-copy-alias! source 'GENERAL target
+ (lambda (target)
+ (conversion target target))
+ conversion))
+
+(define-integrable (convert-object/offset->register target address
+ offset conversion)
+ (let ((source (indirect-reference! address offset)))
+ (conversion source
+ (standard-target-reference target))))
+
+;;; Predicates
+
+(define (predicate/memory-operand? expression)
+ (or (rtl:offset? expression)
+ (and (rtl:post-increment? expression)
+ (interpreter-stack-pointer?
+ (rtl:post-increment-register expression)))))
+
+(define (predicate/memory-operand-reference expression)
+ (case (rtl:expression-type expression)
+ ((OFFSET) (offset->indirect-reference! expression))
+ ((POST-INCREMENT) (INST-EA (@R+ 14)))
+ (else (error "Illegal memory operand" expression))))
+
+(define (compare/register*register register-1 register-2 cc)
+ (set-standard-branches! cc)
+ (LAP (CMP L ,(any-register-reference register-1)
+ ,(any-register-reference register-2))))
+
+(define (compare/register*memory register memory cc)
+ (set-standard-branches! cc)
+ (LAP (CMP L ,(any-register-reference register) ,memory)))
+
+(define (compare/memory*memory memory-1 memory-2 cc)
+ (set-standard-branches! cc)
+ (LAP (CMP L ,memory-1 ,memory-2)))
\f
-;; N is always unsigned.
+;;;; Utilities needed by the rules files (contd.)
-(define (load-rn n r)
- (cond ((zero? n)
- (INST (CLR L (R ,r))))
- ((<= 0 n 63)
- (INST (MOV L (S ,n) (R ,r))))
- ((<= 0 n 127)
- (INST (MOVZ B L (& ,n) (R ,r))))
- ((<= 0 n 32767)
- (INST (MOVZ W L (& ,n) (R ,r))))
- (else
- (INST (MOV L (& ,n) (R ,r))))))
+;;; Interpreter and interface calls
-(define (test-rn n r)
- (cond ((zero? n)
- (INST (TST L (R ,r))))
- ((<= 0 n 63)
- (INST (CMP L (R ,r) (S ,n))))
- (else
- (INST (CMP L (R ,r) (& ,n))))))
+(define (interpreter-call-argument? expression)
+ (or (rtl:register? expression)
+ (rtl:constant? expression)
+ (and (rtl:cons-pointer? expression)
+ (rtl:machine-constant? (rtl:cons-pointer-type expression))
+ (rtl:machine-constant? (rtl:cons-pointer-datum expression)))
+ (and (rtl:offset? expression)
+ (rtl:register? (rtl:offset-base expression)))))
-(define (increment-rn rn n)
- (if (zero? n)
+(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))
+ ((CONSTANT)
+ (LAP ,@(clear-registers! register)
+ ,@(load-constant (rtl:constant-value expression) target)))
+ ((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->indirect-reference! expression)))
+ (LAP ,@(clear-registers! register)
+ (MOV L ,source-reference ,target))))
+ (else
+ (error "Unknown expression type" (car expression))))))
+\f
+;;;; Utilities needed by the rules files (contd.)
+
+;;; Object structure.
+
+(define (cons-pointer/ea type-ea datum target)
+ (LAP (ROTL (S ,scheme-datum-width) ,type-ea ,target)
+ (BIS L ,datum ,target)))
+
+(define (cons-pointer/constant type datum target)
+ (if (ea/same? datum target)
+ (LAP (BIS L (&U ,(make-non-pointer-literal type 0)) ,target))
+ (cons-pointer/ea (INST-EA (S ,type)) datum target)))
+
+(define (set-type/ea type-ea target)
+ (LAP (INSV ,type-ea (S ,scheme-datum-width) (S ,scheme-type-width)
+ ,target)))
+
+(define-integrable (set-type/constant type target)
+ (set-type/ea (INST-EA (S ,type)) target))
+
+(define-integrable (extract-type source target)
+ (LAP (EXTV Z (S ,scheme-datum-width) (S ,scheme-type-width)
+ ,source ,target)))
+
+(define (object->type source target)
+ (extract-type source target))
+
+(define-integrable (ct/object->type object target)
+ (load-immediate (object-type object) target))
+
+(define (object->datum source target)
+ (if (eq? source target)
+ (LAP (BIC L ,mask-reference ,target))
+ (LAP (BIC L ,mask-reference ,source ,target))))
+
+(define-integrable (ct/object->datum object target)
+ (load-immediate (object-datum object) target))
+
+(define (object->address source target)
+ (declare (integrate-operator object->datum))
+ (object->datum source target))
+
+(define-integrable (ct/object->address object target)
+ (declare (integrate-operator ct/object->datum))
+ (ct/object->datum object target))
+
+(define (compare-type type ea)
+ (set-standard-branches! 'EQL)
+ (LAP (CMPV Z (S ,scheme-datum-width) (S ,scheme-type-width)
+ ,ea ,(make-immediate type))))
+\f
+;;;; Utilities needed by the rules files (contd.)
+
+(define-integrable (ea/same? ea1 ea2)
+ (equal? ea1 ea2))
+
+(define (ea/copy source target)
+ (if (ea/same? source target)
(LAP)
- (let ((value (* 4 n)))
- (cond ((<= 0 value 63)
- (LAP (ADD L (S ,value) (R ,rn))))
- ((<= -63 value 0)
- (LAP (SUB L (S ,value) (R ,rn))))
- (else
- (let ((size (datum-size value)))
- (if (not (eq? size 'L))
- (LAP (MOVA L (@RO ,size ,rn ,value)
- (R ,rn)))
- (LAP (ADD L (& ,value) (R ,rn))))))))))
+ (LAP (MOV L ,source ,target))))
+
+(define (increment/ea ea offset)
+ (cond ((zero? offset)
+ (LAP))
+ ((= offset 1)
+ (LAP (INC L ,ea)))
+ ((= offset -1)
+ (LAP (DEC L ,ea)))
+ ((<= 0 offset 63)
+ (LAP (ADD L (S ,offset) ,ea)))
+ ((<= -63 offset 0)
+ (LAP (SUB L (S ,(- 0 offset)) ,ea)))
+ ((effective-address/register? ea)
+ (let ((size (datum-size offset)))
+ (if (not (eq? size 'L))
+ (LAP (MOVA L (@RO ,size ,(lap:ea-R-register ea) ,offset)
+ ,ea))
+ (LAP (ADD L (& ,offset) ,ea)))))
+ (else
+ (LAP (ADD L (& ,offset) ,ea)))))
+
+(define (add-constant/ea source offset target)
+ (if (ea/same? source target)
+ (increment/ea target offset)
+ (cond ((zero? offset)
+ (LAP (MOV L ,source ,target)))
+ ((<= 0 offset 63)
+ (LAP (ADD L (S ,offset) ,source ,target)))
+ ((<= -63 offset 0)
+ (LAP (SUB L (S ,(- 0 offset)) ,source ,target)))
+ ((effective-address/register? source)
+ (let ((size (datum-size offset)))
+ (if (not (eq? size 'L))
+ (LAP (MOVA L (@RO ,size ,(lap:ea-R-register source) ,offset)
+ ,target))
+ (LAP (ADD L (& ,offset) ,source ,target)))))
+ (else
+ (LAP (ADD L (& ,offset) ,source ,target))))))
+
+(define-integrable (increment-rn rn value)
+ (increment/ea (INST-EA (R ,rn)) value))
\f
+;;;; Utilities needed by the rules files (contd.)
+
+;;; Constants
+
+(define (make-immediate value)
+ (if (<= 0 value 63)
+ (INST-EA (S ,value))
+ (INST-EA (& ,value))))
+
(define (constant->ea constant)
(if (non-pointer-object? constant)
- (non-pointer->ea (object-type constant) (object-datum constant))
+ (non-pointer->ea (object-type constant)
+ (careful-object-datum constant))
(INST-EA (@PCR ,(constant->label constant)))))
(define (non-pointer->ea type datum)
- (cond ((not (zero? type))
- (INST-EA (& ,(make-non-pointer-literal type datum))))
- ((<= 0 datum 63)
- (INST-EA (S ,datum)))
- (else
- (INST-EA (& ,datum)))))
-
-(define (push-constant constant)
- (if (non-pointer-object? constant)
- (push-non-pointer (object-type constant)
- (object-datum constant))
- (INST (PUSHL (@PCR ,(constant->label constant))))))
-
-(define (push-non-pointer type datum)
- (cond ((not (zero? type))
- (INST (PUSHL (& ,(make-non-pointer-literal type datum)))))
- ((<= 0 datum 63)
- (INST (PUSHL (S ,datum))))
- (else
- (let ((size (datum-size datum)))
- (if (not (eq? size 'L))
- (INST (CVT ,size L (& ,datum) (@-R 14)))
- (INST (PUSHL (& ,datum))))))))
+ (if (and (zero? type)
+ (<= 0 datum 63))
+ (INST-EA (S ,datum))
+ (INST-EA (&U ,(make-non-pointer-literal type datum)))))
(define (load-constant constant target)
(if (non-pointer-object? constant)
(load-non-pointer (object-type constant)
(object-datum constant)
target)
- (INST (MOV L
- (@PCR ,(constant->label constant))
- ,target))))
+ (LAP (MOV L (@PCR ,(constant->label constant)) ,target))))
(define (load-non-pointer type datum target)
(if (not (zero? type))
- (INST (MOV L
- (& ,(make-non-pointer-literal type datum))
- ,target))
+ (LAP (MOV L (&U ,(make-non-pointer-literal type datum)) ,target))
(load-immediate datum target)))
-(define (load-immediate datum target)
- (cond ((zero? datum)
- (INST (CLR L ,target)))
- ((<= 0 datum 63)
- (INST (MOV L (S ,datum) ,target)))
+(define (load-immediate value target)
+ (cond ((zero? value)
+ (LAP (CLR L ,target)))
+ ((<= 0 value 63)
+ (LAP (MOV L (S ,value) ,target)))
(else
- (let ((size (datum-size datum)))
+ (let ((size (datum-size value)))
(if (not (eq? size 'L))
- (INST (CVT ,size L (& ,datum) ,target))
- (INST (MOV L (& ,datum) ,target)))))))
-
-(define make-non-pointer-literal
- (let ((type-scale-factor (expt 2 24)))
- (lambda (type datum)
- (+ (* (if (negative? datum) (1+ type) type)
- type-scale-factor)
- datum))))
+ (LAP (CVT ,size L (& ,value) ,target))
+ (LAP (MOV L (& ,value) ,target)))))))
+
+(define-integrable (load-rn value rn)
+ (load-immediate value (INST-EA (R ,rn))))
\f
+;;;; Utilities needed by the rules files (contd.)
+
+;;; Predicate utilities
+
+(define (set-standard-branches! condition-code)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (B ,condition-code (@PCR ,label))))
+ (lambda (label)
+ (LAP (B ,(invert-cc condition-code) (@PCR ,label))))))
+
(define (test-byte n effective-address)
(cond ((zero? n)
- (INST (TST B ,effective-address)))
+ (LAP (TST B ,effective-address)))
((<= 0 n 63)
- (INST (CMP B ,effective-address (S ,n))))
+ (LAP (CMP B ,effective-address (S ,n))))
(else
- (INST (CMP B ,effective-address (& ,n))))))
+ (LAP (CMP B ,effective-address (& ,n))))))
(define (test-non-pointer type datum effective-address)
(cond ((not (zero? type))
- (INST (CMP L
- ,effective-address
- (& ,(make-non-pointer-literal type datum)))))
+ (LAP (CMP L
+ ,effective-address
+ (&U ,(make-non-pointer-literal type datum)))))
((zero? datum)
- (INST (TST L ,effective-address)))
+ (LAP (TST L ,effective-address)))
((<= 0 datum 63)
- (INST (CMP L ,effective-address (S ,datum))))
+ (LAP (CMP L ,effective-address (S ,datum))))
(else
- (INST (CMP L
- ,effective-address
- (& ,(make-non-pointer-literal type datum)))))))
-
-(define (set-standard-branches! condition-code)
- (set-current-branches!
- (lambda (label)
- (LAP (B ,condition-code (@PCR ,label))))
- (lambda (label)
- (LAP (B ,(invert-cc condition-code) (@PCR ,label))))))
+ (LAP (CMP L
+ ,effective-address
+ (&U ,(make-non-pointer-literal type datum)))))))
(define (invert-cc condition-code)
(cdr (or (assq condition-code
(GTRU . LSSU) (LSSU . GTRU)
(GEQU . LEQU) (LEQU . GEQU)))
(error "INVERT-CC-NONCOMMUTATIVE: Not a known CC" condition-code))))
-
-(define-integrable (cc-commutative? condition-code)
- (memq condition-code '(NEQ EQL NEQU EQLU VC VS CC CS)))
+\f
+;;;; Utilities needed by the rules files (contd.)
(define-integrable (effective-address/register? ea)
(eq? (lap:ea-keyword ea) 'R))
(define-integrable (effective-address/register-offset? ea)
(eq? (lap:ea-keyword ea) '@RO))
-\f
-(define (standard-target-reference target)
- (delete-dead-registers!)
- (register-reference
- (or (register-alias target 'GENERAL)
- (allocate-alias-register! target 'GENERAL))))
-
-(define-integrable (preferred-register-reference register)
- (register-reference (preferred-register register)))
-
-(define (preferred-register register)
- (or (register-alias register 'GENERAL)
- (load-alias-register! register 'GENERAL)))
(define (offset->indirect-reference! offset)
- (indirect-reference! (rtl:register-number (rtl:offset-register offset))
+ (indirect-reference! (rtl:register-number (rtl:offset-base offset))
(rtl:offset-number offset)))
(define-integrable (indirect-reference! register offset)
(byte-offset-reference (allocate-indirection-register! register) offset))
(define (allocate-indirection-register! register)
- (if (machine-register? register)
- register
- (preferred-register register)))
-
-(define (code-object-label-initialize code-object)
- ;; *** What is this for? ***
- code-object ; ignored
- false)
+ (load-alias-register! register 'GENERAL))
(define (generate-n-times n limit instruction-gen with-counter)
(if (> n limit)
(let ((loop (generate-label 'LOOP)))
(with-counter
- (lambda (counter)
- (LAP ,(load-rn (-1+ n) counter)
- (LABEL ,loop)
- ,(instruction-gen)
- (SOB GEQ (R ,counter) (@PCR ,loop))))))
+ (lambda (counter)
+ (LAP ,@(load-rn (-1+ n) counter)
+ (LABEL ,loop)
+ ,@(instruction-gen)
+ (SOB GEQ (R ,counter) (@PCR ,loop))))))
(let loop ((n n))
(if (zero? n)
(LAP)
- (LAP ,(instruction-gen)
+ (LAP ,@(instruction-gen)
,@(loop (-1+ n)))))))
\f
-;;;; Expression-Generic Operations
-
-(define (expression->machine-register! expression register)
- (let ((target (register-reference register)))
- (let ((result
- (case (car expression)
- ((REGISTER)
- (load-machine-register! (rtl:register-number expression)
- register))
- ((OFFSET)
- (LAP (MOV L ,(offset->indirect-reference! expression) ,target)))
- ((CONSTANT)
- (LAP ,(load-constant (rtl:constant-value expression) target)))
- ((UNASSIGNED)
- (LAP ,(load-non-pointer type-code:unassigned 0 target)))
- (else
- (error "Unknown expression type" (car expression))))))
- (delete-machine-register! register)
- result)))
-
-(define (make-immediate value)
- (if (<= 0 value 63)
- (INST-EA (S ,value))
- (INST-EA (& ,value))))
-
-(define (bump-type ea)
- (cond ((effective-address/register-indirect? ea)
- (INST-EA (@RO B ,(lap:ea-@R-register ea) 3)))
- ((effective-address/register-offset? ea)
- (let ((offset (+ 3 (lap:ea-@RO-offset ea))))
- (INST-EA (@RO ,(datum-size offset)
- ,(lap:ea-@RO-register ea)
- ,offset))))
- (else #F)))
-
-(define (put-type-in-ea type-code ea)
- (cond ((not (effective-address/register? ea))
- (let ((target (bump-type ea)))
- (if target
- (LAP (MOV B ,(make-immediate type-code) ,target))
- (error "PUT-TYPE-IN-EA: Illegal effective address" ea))))
- ((zero? type-code)
- (LAP (BIC L ,mask-reference ,ea)))
- (else
- (LAP (BIC L ,mask-reference ,ea)
- (BIS L (& ,(make-non-pointer-literal type-code 0)) ,ea)))))
-
-(define (standard-target-expression? target)
- (or (rtl:offset? target)
- (rtl:free-push? target)
- (rtl:stack-push? target)))
-
-(define (rtl:free-push? expression)
- (and (rtl:post-increment? expression)
- (interpreter-free-pointer? (rtl:post-increment-register expression))
- (= 1 (rtl:post-increment-number expression))))
-
-(define (rtl:stack-push? expression)
- (and (rtl:pre-increment? expression)
- (interpreter-stack-pointer? (rtl:pre-increment-register expression))
- (= -1 (rtl:pre-increment-number expression))))
-
-(define (standard-target-expression->ea target)
- (cond ((rtl:offset? target) (offset->indirect-reference! target))
- ((rtl:free-push? target) (INST-EA (@R+ 12)))
- ((rtl:stack-push? target) (INST-EA (@-R 14)))
- (else (error "STANDARD-TARGET->EA: Not a standard target" target))))
-
-;; Fixnum stuff moved to rulfix.scm
-\f
-;;;; Datum and character utilities
-
-#|
-;;; OBJECT->DATUM rules - Mhwu
-
-;; These seem unused.
-
-(define (load-constant-datum constant register-ref)
- (if (non-pointer-object? constant)
- (load-non-pointer 0 (object-datum constant) ,register-ref)
- (LAP (MOV L
- (@PCR ,(constant->label constant))
- ,register-ref)
- ,@(object->address register-ref))))
-
-(define (byte-offset->register source source-reg target)
- source-reg ; ignored
- (delete-dead-registers!)
- (let ((target (allocate-alias-register! target 'GENERAL)))
- (LAP (MOVZ B L ,source ,(register-reference target)))))
-|#
+;;;; Utilities needed by the rules files (contd.)
-;;; CHAR->ASCII rules
+;;; CHAR->ASCII utilities
(define (coerce->any/byte-reference register)
(if (machine-register? register)
ascii
(- ascii 256))))
-(define (indirect-register register)
- (if (machine-register? register)
- register
- (register-alias register false)))
-\f
(define-integrable (lap:ea-keyword expression)
(car expression))
(define-integrable (lap:ea-@RO-offset expression)
(cadddr expression))
+\f
+;;;; Utilities needed by the rules files (contd.)
-(define-export (lap:make-label-statement label)
- (INST (LABEL ,label)))
+;;; Layout of the Scheme register array.
-(define-export (lap:make-unconditional-branch label)
- (INST (BR (@PCR ,label)))) ; Unsized
+(define-integrable reg:compiled-memtop (INST-EA (@R 10)))
+(define-integrable reg:environment (INST-EA (@RO B 10 #x000C)))
+(define-integrable reg:temp (INST-EA (@RO B 10 #x0010)))
+(define-integrable reg:lexpr-primitive-arity (INST-EA (@RO B 10 #x001C)))
-(define-export (lap:make-entry-point label block-start-label)
- block-start-label
- (LAP (ENTRY-POINT ,label)
- ,@(make-external-label expression-code-word label)))
+(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))
(let-syntax ((define-entries
(macro (start . names)
(cons `(DEFINE-INTEGRABLE
,(symbol-append 'ENTRY:COMPILER-
(car names))
- (INST-EA (@RO W 13 ,index)))
- (loop (cdr names) (+ index 6)))))
+ (INST-EA (@RO B 10 ,index)))
+ (loop (cdr names) (+ index 8)))))
`(BEGIN ,@(loop names start)))))
- (define-entries #x0280
- link error apply
- lexpr-apply primitive-apply primitive-lexpr-apply
- cache-reference-apply lookup-apply
- interrupt-continuation interrupt-ic-procedure
- interrupt-procedure interrupt-closure
- lookup safe-lookup set! access unassigned? unbound? define
- reference-trap safe-reference-trap assignment-trap unassigned?-trap
- &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?))
-
-(define-integrable reg:compiled-memtop (INST-EA (@R 13)))
-(define-integrable reg:environment (INST-EA (@RO B 13 #x0C)))
-(define-integrable reg:temp (INST-EA (@RO B 13 #x10)))
-(define-integrable reg:lexpr-primitive-arity (INST-EA (@RO B 13 #x1C)))
-\f
-;;;; Higher level rules - assignment
-
-(define-integrable (convert-object/constant->register target constant
- rtconversion
- ctconversion)
- (let ((target (standard-target-reference target)))
- (if (non-pointer-object? constant)
- (ctconversion constant target)
- (rtconversion (constant->ea constant) target))))
-
-(define-integrable (convert-object/register->register target source conversion)
- ;; `conversion' often expands into multiple references to `target'.
- (with-register-copy-alias! source 'GENERAL target
- (lambda (target)
- (conversion target target))
- conversion))
-
-(define-integrable (convert-object/offset->register target address
- offset conversion)
- (let ((source (indirect-reference! address offset)))
- (conversion source
- (standard-target-reference target))))
-\f
-;;;; Higher level rules - predicates
-
-(define (predicate/memory-operand? expression)
- (or (rtl:offset? expression)
- (and (rtl:post-increment? expression)
- (interpreter-stack-pointer?
- (rtl:post-increment-register expression)))))
+ (define-entries #x40
+ scheme-to-interface ; Main entry point (only one necessary)
+ scheme-to-interface-jsb ; Used by rules3&4, for convenience.
+ trampoline-to-interface ; Used by trampolines, for convenience.
+ ;; If more are added, the size of the addressing mode must be changed.
+ ))
-(define (predicate/memory-operand-reference expression)
- (case (rtl:expression-type expression)
- ((OFFSET) (offset->indirect-reference! expression))
- ((POST-INCREMENT) (INST-EA (@R+ 14)))
- (else (error "Illegal memory operand" expression))))
-
-(define (compare/register*register register-1 register-2 cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,(standard-register-reference register-1 false)
- ,(standard-register-reference register-2 false))))
+(define-integrable (invoke-interface code)
+ (LAP ,@(load-rn code 0)
+ (JMP ,entry:compiler-scheme-to-interface)))
-(define (compare/register*memory register memory cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,(standard-register-reference register false) ,memory)))
+#|
+;; If the entry point scheme-to-interface-jsb were not available,
+;; this code should replace the definition below.
+;; The others can be handled similarly.
+
+(define-integrable (invoke-interface-jsb code)
+ (LAP ,@(load-rn code 0)
+ (MOVA B (@PCO B 10) (R 1))
+ (JMP ,entry:compiler-scheme-to-interface)))
+|#
-(define (compare/memory*memory memory-1 memory-2 cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,memory-1 ,memory-2)))
\ No newline at end of file
+(define-integrable (invoke-interface-jsb code)
+ (LAP ,@(load-rn code 0)
+ (JSB ,entry:compiler-scheme-to-interface-jsb)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/machin.scm,v 4.6 1989/09/05 22:34:32 arthur Rel $
-$MC68020-Header: machin.scm,v 4.14 89/01/18 09:58:56 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/machin.scm,v 4.7 1991/02/15 00:42:01 jinx Exp $
+$MC68020-Header: machin.scm,v 4.23 1991/02/05 03:50:50 jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; Machine Model for DEC Vax
+;;; package: (compiler)
(declare (usual-integrations))
\f
-;;; Floating-point open-coding not implemented for VAXen.
-(define compiler:open-code-floating-point-arithmetic? false)
-
-;;; Size of words. Some of the stuff in "assmd.scm" might want to
-;;; come here.
+;;;; Architecture Parameters
+(define-integrable endianness 'LITTLE)
(define-integrable addressing-granularity 8)
(define-integrable scheme-object-width 32)
-(define-integrable scheme-datum-width 24)
-(define-integrable scheme-type-width 8)
-
-;; It is currently required that both packed characters and objects be
-;; integrable numbers of address units. Furthermore, the number of
-;; address units per object must be an integral multiple of the number
-;; of address units per character. This will cause problems on a
-;; machine that is word addressed, in which case we will have to
-;; rethink the character addressing strategy.
-(define-integrable address-units-per-object 4)
+(define-integrable scheme-type-width 6) ;or 8
+
+;; NOTE: expt is not being constant-folded now.
+;; For the time being, some of the parameters below are
+;; pre-computed and marked with ***
+;; There are similar parameters in lapgen.scm
+;; Change them if any of the parameters above change.
+
+(define-integrable scheme-datum-width
+ (- scheme-object-width scheme-type-width))
+
+(define-integrable flonum-size 2)
+(define-integrable float-alignment 32)
+
+;;; It is currently required that both packed characters and objects
+;;; be integrable numbers of address units. Furthermore, the number
+;;; of address units per object must be an integral multiple of the
+;;; number of address units per character. This will cause problems
+;;; on a machine that is word addressed: we will have to rethink the
+;;; character addressing strategy.
+
+(define-integrable address-units-per-object
+ (quotient scheme-object-width addressing-granularity))
+
(define-integrable address-units-per-packed-char 1)
-(let-syntax ((fold
- (macro (expression)
- (eval expression system-global-environment))))
- (define-integrable unsigned-fixnum/upper-limit (fold (expt 2 24)))
- (define-integrable signed-fixnum/upper-limit (fold (expt 2 23)))
- (define-integrable signed-fixnum/lower-limit (fold (- (expt 2 23)))))
+(define-integrable signed-fixnum/upper-limit
+ ;; (expt 2 (-1+ scheme-datum-width)) ***
+ 33554432)
-(define-integrable (stack->memory-offset offset)
- offset)
+(define-integrable signed-fixnum/lower-limit
+ (- signed-fixnum/upper-limit))
-(define ic-block-first-parameter-offset
- 2)
+(define-integrable unsigned-fixnum/upper-limit
+ (* 2 signed-fixnum/upper-limit))
-(define closure-block-first-offset
- 2)
+(define-integrable (stack->memory-offset offset) offset)
+(define-integrable ic-block-first-parameter-offset 2)
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER) (interpreter-stack-pointer))
- ((DYNAMIC-LINK) (interpreter-dynamic-link))
- ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
- (interpreter-register:cache-reference))
- ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
- (interpreter-register:cache-unassigned?))
- ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?))
- (else false)))
+;; This must return a word based offset.
+;; On the VAX, to save space, entries can be at 2 mod 4 addresses,
+;; which makes it impossible if the closure object used for
+;; referencing points to arbitrary entries. Instead, all closure
+;; entry points bump to the canonical entry point, which is always
+;; longword aligned.
+;; On other machines (word aligned), it may be easier to bump back
+;; to each entry point, and the entry number `entry' would be part
+;; of the computation.
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((MEMORY-TOP) 0)
- ((STACK-GUARD) 1)
- ((VALUE) 2)
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- (else false)))
+(define (closure-first-offset nentries entry)
+ entry ; ignored
+ (if (zero? nentries)
+ 1
+ (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2)))
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
+;; This is from the start of the complete closure object,
+;; viewed as a vector, and including the header word.
-(define (rtl:constant-cost constant)
- ;; Magic numbers. Ask RMS where they came from.
- (if (and (object-type? 0 constant)
- (zero? (object-datum constant)))
- 0
- 3))
-\f
-(define-integrable r0 0)
+(define (closure-object-first-offset nentries)
+ (case nentries
+ ((0) 1)
+ ((1) 4)
+ (else
+ (quotient (+ 5 (* 5 nentries)) 2))))
+
+;; Bump from one entry point to another.
+
+(define (closure-entry-distance nentries entry entry*)
+ nentries ; ignored
+ (* 10 (- entry* entry)))
+
+;; Bump to the canonical entry point.
+
+(define (closure-environment-adjustment nentries entry)
+ (declare (integrate-operator closure-entry-distance))
+ (closure-entry-distance nentries entry 0))
+
+(define-integrable r0 0) ; return value
(define-integrable r1 1)
(define-integrable r2 2)
(define-integrable r3 3)
(define-integrable r9 9)
(define-integrable r10 10)
(define-integrable r11 11)
-(define-integrable r12 12)
-(define-integrable r13 13)
-(define-integrable r14 14)
-(define-integrable r15 15)
+(define-integrable r12 12) ; AP
+(define-integrable r13 13) ; FP
+(define-integrable r14 14) ; SP
+(define-integrable r15 15) ; PC, not really useable.
+
(define number-of-machine-registers 16)
-;; Each is a quadword long
(define number-of-temporary-registers 256)
-(define-integrable regnum:dynamic-link r10)
+(define-integrable regnum:return-value r9)
+(define-integrable regnum:regs-pointer r10)
+(define-integrable regnum:pointer-mask r11)
(define-integrable regnum:free-pointer r12)
-(define-integrable regnum:regs-pointer r13)
+(define-integrable regnum:dynamic-link r13)
(define-integrable regnum:stack-pointer r14)
+(define-integrable (machine-register-known-value register) register false)
-(define-integrable (sort-machine-registers registers)
- registers)
-
-(define available-machine-registers
- (list r0 r1 r2 r3 r4 r5 r6 r7 r8 r9))
-
-(define initial-non-object-registers
- (list r10 r11 r12 r13 r14 r15))
-
-(define-integrable (register-type register)
- ;; This may have to be changed when floating support is added.
- 'GENERAL)
-
-(define register-reference
- (let ((references (make-vector 16)))
- (let loop ((i 0))
- (if (< i 16)
- (begin
- (vector-set! references i (INST-EA (R ,i)))
- (loop (1+ i)))))
- (lambda (register)
- (vector-ref references register))))
-
-(define mask-reference (INST-EA (R 11)))
+(define (machine-register-value-class register)
+ (cond ((<= 0 register 9) value-class=object)
+ ((= 11 register) value-class=immediate)
+ ((<= 10 register 15) value-class=address)
+ (else (error "illegal machine register" register))))
\f
-;; These must agree with cmpvax.m4
+;;;; RTL Generator Interface
-(define-integrable (interpreter-register:access)
+(define (interpreter-register:access)
(rtl:make-machine-register r0))
-(define-integrable (interpreter-register:cache-reference)
+(define (interpreter-register:cache-reference)
(rtl:make-machine-register r0))
-(define-integrable (interpreter-register:cache-unassigned?)
+(define (interpreter-register:cache-unassigned?)
(rtl:make-machine-register r0))
-(define-integrable (interpreter-register:lookup)
+(define (interpreter-register:lookup)
(rtl:make-machine-register r0))
-(define-integrable (interpreter-register:unassigned?)
+(define (interpreter-register:unassigned?)
(rtl:make-machine-register r0))
-(define-integrable (interpreter-register:unbound?)
+(define (interpreter-register:unbound?)
(rtl:make-machine-register r0))
(define-integrable (interpreter-value-register)
- (rtl:make-offset (interpreter-regs-pointer) 2))
+ (rtl:make-machine-register regnum:return-value))
(define (interpreter-value-register? expression)
- (and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-register expression))
- (= 2 (rtl:offset-number expression))))
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:return-value)))
-(define-integrable (interpreter-environment-register)
+(define (interpreter-environment-register)
(rtl:make-offset (interpreter-regs-pointer) 3))
(define (interpreter-environment-register? expression)
(and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-register expression))
+ (interpreter-regs-pointer? (rtl:offset-base expression))
(= 3 (rtl:offset-number expression))))
-(define-integrable (interpreter-free-pointer)
+(define (interpreter-free-pointer)
(rtl:make-machine-register regnum:free-pointer))
-(define-integrable (interpreter-free-pointer? register)
- (= (rtl:register-number register) regnum:free-pointer))
+(define (interpreter-free-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:free-pointer)))
-(define-integrable (interpreter-regs-pointer)
+(define (interpreter-regs-pointer)
(rtl:make-machine-register regnum:regs-pointer))
-(define-integrable (interpreter-regs-pointer? register)
- (= (rtl:register-number register) regnum:regs-pointer))
+(define (interpreter-regs-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:regs-pointer)))
-(define-integrable (interpreter-stack-pointer)
+(define (interpreter-stack-pointer)
(rtl:make-machine-register regnum:stack-pointer))
-(define-integrable (interpreter-stack-pointer? register)
- (= (rtl:register-number register) regnum:stack-pointer))
+(define (interpreter-stack-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:stack-pointer)))
-(define-integrable (interpreter-dynamic-link)
+(define (interpreter-dynamic-link)
(rtl:make-machine-register regnum:dynamic-link))
-(define-integrable (interpreter-dynamic-link? register)
- (= (rtl:register-number register) regnum:dynamic-link))
\ No newline at end of file
+(define (interpreter-dynamic-link? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:dynamic-link)))
+\f
+(define (rtl:machine-register? rtl-register)
+ (case rtl-register
+ ((STACK-POINTER)
+ (interpreter-stack-pointer))
+ ((DYNAMIC-LINK)
+ (interpreter-dynamic-link))
+ ((VALUE)
+ (interpreter-value-register))
+ ((INTERPRETER-CALL-RESULT:ACCESS)
+ (interpreter-register:access))
+ ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
+ (interpreter-register:cache-reference))
+ ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
+ (interpreter-register:cache-unassigned?))
+ ((INTERPRETER-CALL-RESULT:LOOKUP)
+ (interpreter-register:lookup))
+ ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
+ (interpreter-register:unassigned?))
+ ((INTERPRETER-CALL-RESULT:UNBOUND?)
+ (interpreter-register:unbound?))
+ (else
+ false)))
+
+(define (rtl:interpreter-register? rtl-register)
+ (case rtl-register
+ ((MEMORY-TOP) 0)
+ ((STACK-GUARD) 1)
+ #| ((VALUE) 2) |#
+ ((ENVIRONMENT) 3)
+ ((TEMPORARY) 4)
+ (else false)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown register type" locative)))
+
+(define (rtl:constant-cost expression)
+ ;; Magic numbers
+ ;; number of bytes for the instruction to construct/fetch into register.
+ (let ((if-integer
+ (lambda (value)
+ (cond ((zero? value) 2)
+ ((<= -63 value 63)
+ 3)
+ (else
+ 7)))))
+ (let ((if-synthesized-constant
+ (lambda (type datum)
+ (if-integer (make-non-pointer-literal type datum)))))
+ (case (rtl:expression-type expression)
+ ((CONSTANT)
+ (let ((value (rtl:constant-value expression)))
+ (if (non-pointer-object? value)
+ (if-synthesized-constant (object-type value)
+ (careful-object-datum value))
+ 3)))
+ ((MACHINE-CONSTANT)
+ (if-integer (rtl:machine-constant-value expression)))
+ ((ENTRY:PROCEDURE
+ ENTRY:CONTINUATION
+ ASSIGNMENT-CACHE
+ VARIABLE-CACHE
+ OFFSET-ADDRESS
+ BYTE-OFFSET-ADDRESS)
+ 4) ; assuming word offset
+ ((CONS-POINTER)
+ (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
+ (rtl:machine-constant? (rtl:cons-pointer-datum expression))
+ (if-synthesized-constant
+ (rtl:machine-constant-value (rtl:cons-pointer-type expression))
+ (rtl:machine-constant-value
+ (rtl:cons-pointer-datum expression)))))
+ (else false)))))
+
+;;; Floating-point open-coding not implemented for VAXen.
+
+(define compiler:open-code-floating-point-arithmetic?
+ false)
+
+(define compiler:primitives-with-no-open-coding
+ '(DIVIDE-FIXNUM GCD-FIXNUM &/))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/make.scm,v 4.45 1989/08/02 01:36:55 cph Rel $
-$MC68020-Header: make.scm,v 4.44 89/05/21 14:52:30 GMT jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/make.scm,v 4.46 1991/02/15 00:42:07 jinx Exp $
+$MC68020-Header: make.scm,v 4.77 90/11/19 22:51:08 GMT cph Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
'((COMPILER MACROS)
(COMPILER DECLARATIONS)
(COMPILER DISASSEMBLER MACROS)))
-(add-system! (make-system "Liar (DEC VAX)" 4 45 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (DEC VAX)" 4 77 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules1.scm,v 4.6 1989/05/21 03:55:50 jinx Rel $
-$MC68020-Header: rules1.scm,v 4.22 89/04/27 20:06:32 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules1.scm,v 4.7 1991/02/15 00:42:13 jinx Exp $
+$MC68020-Header: rules1.scm,v 4.34 1991/01/23 21:34:30 jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; LAP Generation Rules: Data Transfers. DEC VAX version.
-;;; Note: All fixnum code has been moved to rulfix.scm.
+;;;; LAP Generation Rules: Data Transfers.
+;;; Note: All fixnum code is in rulfix.scm
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
-;;;; Transfers to Registers
+;;;; 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)))
- (QUALIFIER (machine-register? target))
- (LAP (MOV L
- ,(standard-register-reference source false)
- ,(register-reference target))))
+ (assign-register->register target source))
(define-rule statement
- (ASSIGN (REGISTER 14) (OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
- (QUALIFIER (pseudo-register? source))
- (LAP (MOVA L ,(indirect-reference! source offset) (R 14))))
+ (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
+ (load-displaced-register target source (* 4 n)))
(define-rule statement
- (ASSIGN (REGISTER 14) (OFFSET-ADDRESS (REGISTER 14) (? n)))
- (increment-rn 14 n))
+ ;; This is an intermediate rule -- not intended to produce code.
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (load-displaced-register/typed target source type (* 4 n)))
(define-rule statement
- (ASSIGN (REGISTER 10) (OFFSET-ADDRESS (REGISTER 14) (? offset)))
- (let ((real-offset (* 4 offset)))
- (LAP (MOVA L (@RO ,(datum-size real-offset) 14 ,real-offset) (R 10)))))
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n)))
+ (load-displaced-register target source n))
(define-rule statement
- (ASSIGN (REGISTER 10) (OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
- (QUALIFIER (pseudo-register? source))
- (LAP (MOVA L ,(indirect-reference! source offset) (R 10))))
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (load-displaced-register/typed target source type n))
(define-rule statement
- (ASSIGN (REGISTER 10) (OBJECT->ADDRESS (REGISTER (? source))))
- (QUALIFIER (pseudo-register? source))
- (let ((source (preferred-register-reference source)))
- (LAP (BIC L ,mask-reference ,source (R 10)))))
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (convert-object/register->register target source object->type))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (cond ((register-copy-if-available datum 'GENERAL target)
+ =>
+ (lambda (get-datum-alias)
+ (let* ((type (any-register-reference type))
+ (datum&target (get-datum-alias)))
+ (set-type/ea type datum&target))))
+ ((register-copy-if-available type 'GENERAL target)
+ =>
+ (lambda (get-type-alias)
+ (let* ((datum (any-register-reference datum))
+ (type&target (get-type-alias)))
+ (cons-pointer/ea type&target datum type&target))))
+ (else
+ (let* ((type (any-register-reference type))
+ (datum (any-register-reference datum))
+ (target (standard-target-reference target)))
+ (cons-pointer/ea type datum target)))))
(define-rule statement
- (ASSIGN (REGISTER 10) (OBJECT->ADDRESS (POST-INCREMENT (REGISTER 14) 1)))
- (LAP (BIC L ,mask-reference (@R+ 14) (R 10))))
-\f
-;;; All assignments to pseudo registers are required to delete the
-;;; dead registers BEFORE performing the assignment. However, it is
-;;; necessary to derive the effective address of the source
-;;; expression(s) before deleting the dead registers. Otherwise any
-;;; source expression containing dead registers might refer to aliases
-;;; which have been reused.
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
+ (if (zero? type)
+ (assign-register->register target datum)
+ (with-register-copy-alias! datum 'GENERAL target
+ (lambda (alias)
+ (set-type/constant type alias))
+ (lambda (datum target)
+ (cons-pointer/constant type datum target)))))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
- (QUALIFIER (and (pseudo-register? target) (machine-register? source)))
- (let ((source (indirect-reference! source n)))
- (LAP (MOVA L ,source ,(standard-target-reference target)))))
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+ (convert-object/register->register target source object->datum))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
- (QUALIFIER (and (pseudo-register? target) (pseudo-register? source)))
- (reuse-pseudo-register-alias! source 'GENERAL
- (lambda (reusable-alias)
- (delete-dead-registers!)
- (add-pseudo-register-alias! target reusable-alias)
- (increment-rn reusable-alias n))
- (lambda ()
- ;; *** This could use an add instruction. ***
- (let ((source (indirect-reference! source n)))
- (LAP (MOVA L ,source ,(standard-target-reference target)))))))
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (convert-object/register->register target source object->address))
+\f
+;;;; Loading Constants
(define-rule statement
(ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (QUALIFIER (pseudo-register? target))
- (LAP ,(load-constant source (standard-target-reference target))))
+ (load-constant source (standard-target-reference target)))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
- (QUALIFIER (pseudo-register? target))
- (LAP (MOV L
- (@PCR ,(free-reference-label name))
- ,(standard-target-reference target))))
+ (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
+ (load-immediate n (standard-target-reference target)))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
- (QUALIFIER (pseudo-register? target))
- (LAP (MOV L
- (@PCR ,(free-assignment-label name))
- ,(standard-target-reference target))))
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (load-non-pointer type datum (standard-target-reference target)))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (QUALIFIER (pseudo-register? target))
- (move-to-alias-register! source 'GENERAL target)
- (LAP))
-\f
-(define (object->address source reg-ref)
- (if (eq? source reg-ref)
- (LAP (BIC L ,mask-reference ,reg-ref))
- (LAP (BIC L ,mask-reference ,source ,reg-ref))))
+ (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
+ (load-pc-relative-address
+ target
+ (rtl-procedure/external-label (label->object label))))
-(define-integrable (ct/object->address object target)
- (LAP ,(load-immediate (object-datum object) target)))
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
+ (load-pc-relative-address target label))
-(define (object->datum source reg-ref)
- (if (eq? source reg-ref)
- (LAP (BIC L ,mask-reference ,reg-ref))
- (LAP (BIC L ,mask-reference ,source ,reg-ref))))
+(define-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
+ type
+ (rtl-procedure/external-label
+ (label->object label))))
-(define-integrable (ct/object->datum object target)
- (LAP ,(load-immediate (object-datum object) target)))
+(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 type label))
-(define-integrable (object->type source reg-ref)
- (LAP (ROTL (S 8) ,source ,reg-ref)))
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+ (load-pc-relative target (free-reference-label name)))
-(define-integrable (ct/object->type object target)
- (LAP ,(load-immediate (object-type object) target)))
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
+ (load-pc-relative target (free-assignment-label name)))
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
- (QUALIFIER (pseudo-register? target))
(convert-object/constant->register target constant
- object->datum
- ct/object->datum))
+ object->datum ct/object->datum))
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? constant))))
- (QUALIFIER (pseudo-register? target))
(convert-object/constant->register target constant
- object->address
- ct/object->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (convert-object/register->register target source object->type))
+ object->address ct/object->address))
+\f
+;;;; Transfers from Memory
(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (convert-object/register->register target source object->datum))
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset))))
+ (convert-object/offset->register target address offset object->type))
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (convert-object/register->register target source object->address))
-\f
(define-rule statement
(ASSIGN (REGISTER (? target))
(OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset))))
- (QUALIFIER (pseudo-register? target))
(convert-object/offset->register target address offset object->datum))
(define-rule statement
(ASSIGN (REGISTER (? target))
(OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset))))
- (QUALIFIER (pseudo-register? target))
(convert-object/offset->register target address offset object->address))
(define-rule statement
(ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
- (QUALIFIER (pseudo-register? target))
(let ((source (indirect-reference! address offset)))
(LAP (MOV L ,source ,(standard-target-reference target)))))
(define-rule statement
(ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 14) 1))
- (QUALIFIER (pseudo-register? target))
(LAP (MOV L (@R+ 14) ,(standard-target-reference target))))
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
- (QUALIFIER (and (pseudo-register? target) (machine-register? datum)))
- (let ((target (standard-target-reference target)))
- (LAP (BIS L (& ,(make-non-pointer-literal type 0))
- ,(register-reference datum) ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
- (QUALIFIER (and (pseudo-register? target) (pseudo-register? datum)))
- (with-register-copy-alias! datum 'GENERAL target
- (lambda (target)
- (LAP (BIS L (& ,(make-non-pointer-literal type 0)) ,target)))
- (lambda (source target)
- (LAP (BIS L (& ,(make-non-pointer-literal type 0)) ,source ,target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (CONSTANT (? type)) (CONSTANT (? datum))))
- (QUALIFIER (pseudo-register? target))
- (LAP ,(load-non-pointer type datum (standard-target-reference target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label))))
- (QUALIFIER (pseudo-register? target))
- (let ((target (standard-target-reference target)))
- (LAP (MOVA B
- (@PCR ,(rtl-procedure/external-label (label->object label)))
- ,target)
- (BIS L (& ,(make-non-pointer-literal type 0)) ,target))))
-\f
;;;; Transfers to Memory
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(CONSTANT (? object)))
- (LAP ,(load-constant object (indirect-reference! a n))))
+ (load-constant object (indirect-reference! a n)))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (UNASSIGNED))
- (LAP ,(load-non-pointer (ucode-type unassigned)
- 0
- (indirect-reference! a n))))
-
-;; 1,3,4,5 of the following may need to do a delete-dead-registers!
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (load-non-pointer type datum (indirect-reference! a n)))
(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (REGISTER (? r)))
- (let ((target (indirect-reference! a n)))
- (LAP (MOV L
- ,(standard-register-reference r false)
- ,target))))
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r)))
+ (QUALIFIER (register-value-class=word? r))
+ (LAP (MOV L
+ ,(any-register-reference r)
+ ,(indirect-reference! a n))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(POST-INCREMENT (REGISTER 14) 1))
(LAP (MOV L (@R+ 14) ,(indirect-reference! a n))))
-
+\f
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
(let ((target (indirect-reference! address offset)))
- (LAP (BIS L ,(make-immediate (make-non-pointer-literal type 0))
- ,(standard-register-reference datum false)
- ,target))))
+ (cons-pointer/constant type
+ (any-register-reference datum)
+ target)))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (store-displaced-register/typed address offset type source (* 4 n)))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label))))
- (let ((temp (reference-temporary-register! 'GENERAL))
- (target (indirect-reference! address offset)))
- (LAP (MOVA B (@PCR ,(rtl-procedure/external-label (label->object label)))
- ,temp)
- (BIS L ,(make-immediate (make-non-pointer-literal type 0))
- ,temp ,target))))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (store-displaced-register/typed address offset type source n))
+
+;; Common case that can be done cheaply:
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (BYTE-OFFSET-ADDRESS (OFFSET (REGISTER (? address)) (? offset))
+ (? n)))
+ (if (zero? n)
+ (LAP)
+ (increment/ea (indirect-reference! address offset) n)))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:PROCEDURE (? label))))
+ (let ((target (indirect-reference! address offset))
+ (label (rtl-procedure/external-label (label->object label))))
+ #|
+ (LAP (MOVA B (@PCR ,label) ,target)
+ ,@(set-type/constant type target))
+ |#
+ (LAP (MOVA B (@PCRO ,label ,(make-non-pointer-literal type 0)) ,target))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
(OFFSET (REGISTER (? a1)) (? n1)))
- (let ((source (indirect-reference! a1 n1)))
- (LAP (MOV L ,source ,(indirect-reference! a0 n0)))))
+ (if (and (= a0 a1) (= n0 n1))
+ (LAP)
+ (let ((source (indirect-reference! a1 n1)))
+ (LAP (MOV L ,source ,(indirect-reference! a0 n0))))))
\f
;;;; Consing
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 12) 1) (CONSTANT (? object)))
- (LAP ,(load-constant object (INST-EA (@R+ 12)))))
+ (load-constant object (INST-EA (@R+ 12))))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 12) 1)
- (CONS-POINTER (CONSTANT (? type)) (CONSTANT (? datum))))
- (LAP ,(load-non-pointer type datum (INST-EA (@R+ 12)))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (UNASSIGNED))
- (LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@R+ 12)))))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (load-non-pointer type datum (INST-EA (@R+ 12))))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 12) 1) (REGISTER (? r)))
- (LAP (MOV L ,(standard-register-reference r false) (@R+ 12))))
+ (QUALIFIER (register-value-class=word? r))
+ (LAP (MOV L ,(any-register-reference r) (@R+ 12))))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 12) 1) (OFFSET (REGISTER (? r)) (? n)))
;; This pops the top of stack into the heap
(ASSIGN (POST-INCREMENT (REGISTER 12) 1) (POST-INCREMENT (REGISTER 14) 1))
(LAP (MOV L (@R+ 14) (@R+ 12))))
-\f
+
;;;; Pushes
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (REGISTER (? r)))
+ (QUALIFIER (register-value-class=word? r))
+ (LAP (PUSHL ,(any-register-reference r))))
+
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (CONSTANT (? object)))
- (LAP ,(push-constant object)))
+ (LAP (PUSHL ,(constant->ea object))))
(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (UNASSIGNED))
- (LAP ,(push-non-pointer (ucode-type unassigned) 0)))
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
+ (LAP (PUSHL ,(any-register-reference datum))
+ ,@(set-type/constant type (INST-EA (@R 14)))))
(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (REGISTER (? r)))
- (LAP (PUSHL ,(standard-register-reference r false))))
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (LAP (PUSHL ,(non-pointer->ea type datum))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
- (LAP (PUSHL ,(standard-register-reference datum 'GENERAL))
- (MOV B (S ,type) (@RO B 14 3))))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:PROCEDURE (? label))))
+ (push-pc-relative-address/typed type
+ (rtl-procedure/external-label
+ (label->object label))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
- (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label))))
- (LAP (PUSHA B (@PCR ,(rtl-procedure/external-label (label->object label))))
- (MOV B (S ,type) (@RO B 14 3))))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:CONTINUATION (? label))))
+ (push-pc-relative-address/typed type label))
(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (OFFSET (REGISTER (? r)) (? n)))
- (LAP (PUSHL ,(indirect-reference! r n))))
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (OFFSET-ADDRESS (REGISTER (? r)) (? n))))
+ (push-displaced-register/typed type r (* 4 n)))
(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (ENTRY:CONTINUATION (? label)))
- (LAP (PUSHA B (@PCR ,label))
- (MOV B (S ,(ucode-type compiled-entry)) (@RO B 14 3))))
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? r)) (? n))))
+ (push-displaced-register/typed type r n))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (OFFSET (REGISTER (? r)) (? n)))
+ (LAP (PUSHL ,(indirect-reference! r n))))
\f
;;;; CHAR->ASCII/BYTE-OFFSET
-(define (load-char-into-register type source target)
- (let ((target (standard-target-reference target)))
- (if (not (zero? type))
- (LAP ,(load-non-pointer type 0 target)
- (MOV B ,source ,target))
- (LAP (MOVZ B L ,source ,target)))))
-
(define-rule statement
(ASSIGN (REGISTER (? target))
(CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
- (QUALIFIER (pseudo-register? target))
(load-char-into-register 0
(indirect-char/ascii-reference! address offset)
target))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CHAR->ASCII (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (let ((source (machine-register-reference source 'GENERAL)))
- (load-char-into-register 0 source target)))
+ (load-char-into-register 0
+ (reference-alias-register! source 'GENERAL)
+ target))
(define-rule statement
(ASSIGN (REGISTER (? target))
(BYTE-OFFSET (REGISTER (? address)) (? offset)))
- (QUALIFIER (pseudo-register? target))
(load-char-into-register 0
(indirect-byte-reference! address offset)
target))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (CONS-POINTER (CONSTANT (? type))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
(BYTE-OFFSET (REGISTER (? address)) (? offset))))
- (QUALIFIER (pseudo-register? target))
(load-char-into-register type
(indirect-byte-reference! address offset)
target))
(ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
(CHAR->ASCII (CONSTANT (? character))))
(LAP (MOV B
- ,(make-immediate (char->signed-8-bit-immediate character))
+ (& ,(char->signed-8-bit-immediate character))
,(indirect-byte-reference! address offset))))
(define-rule statement
(ASSIGN (BYTE-OFFSET (REGISTER (? target)) (? target-offset))
(CHAR->ASCII (OFFSET (REGISTER (? source)) (? source-offset))))
(let ((source (indirect-char/ascii-reference! source source-offset)))
- (LAP (MOV B ,source ,(indirect-byte-reference! target target-offset)))))
\ No newline at end of file
+ (LAP (MOV B ,source ,(indirect-byte-reference! target target-offset)))))
+\f
+;;;; Utilities specific to rules1 (others in lapgen)
+
+(define (load-displaced-register target source n)
+ (if (zero? n)
+ (assign-register->register target source)
+ (with-register-copy-alias! source 'GENERAL target
+ (lambda (reusable-alias)
+ (increment/ea reusable-alias n))
+ (lambda (source target)
+ (add-constant/ea source n target)))))
+
+(define (load-displaced-register/typed target source type n)
+ (if (zero? type)
+ (load-displaced-register target source n)
+ (let ((unsigned-offset (+ (make-non-pointer-literal type 0) n)))
+ (with-register-copy-alias! source 'GENERAL target
+ (lambda (reusable-alias)
+ (LAP (ADD L (&U ,unsigned-offset) ,reusable-alias)))
+ (lambda (source target)
+ (LAP (ADD L (&U ,unsigned-offset) ,source ,target)))))))
+
+(define (store-displaced-register/typed address offset type source n)
+ (let* ((source (any-register-reference source))
+ (target (indirect-reference! address offset)))
+ (if (zero? type)
+ (add-constant/ea source n target)
+ (LAP (ADD L (&U ,(+ (make-non-pointer-literal type 0) n))
+ ,source ,target)))))
+
+(define (push-displaced-register/typed type r n)
+ (if (zero? type)
+ (LAP (PUSHA B ,(indirect-byte-reference! r n)))
+ #|
+ (LAP (PUSHA B ,(indirect-byte-reference! r n))
+ (set-type/constant type (INST-EA (@R 14))))
+ |#
+ (let ((reg (allocate-indirection-register! r)))
+ (LAP (PUSHA B (@RO UL ,reg ,(+ (make-non-pointer-literal type 0)
+ n)))))))
+
+(define (assign-register->register target source)
+ (move-to-alias-register! source (register-type target) target)
+ (LAP))
+
+(define (load-pc-relative target label)
+ (LAP (MOV L (@PCR ,label) ,(standard-target-reference target))))
+
+(define (load-pc-relative-address target label)
+ (LAP (MOVA B (@PCR ,label) ,(standard-target-reference target))))
+
+(define (load-pc-relative-address/typed target type label)
+ (let ((target (standard-target-reference target)))
+ #|
+ (LAP (MOVA B (@PCR ,label) ,target)
+ ,@(set-type/constant type target))
+ |#
+ (LAP (MOVA B (@PCRO ,label ,(make-non-pointer-literal type 0)) ,target))))
+
+(define (push-pc-relative-address/typed type label)
+ #|
+ (LAP (PUSHA B (@PCR ,label))
+ ,@(set-type/constant type (INST-EA (@R 14))))
+ |#
+ (LAP (PUSHA B (@PCRO ,label ,(make-non-pointer-literal type 0)))))
+
+(define (load-char-into-register type source target)
+ (let ((target (standard-target-reference target)))
+ (LAP ,@(load-non-pointer type 0 target)
+ (MOV B ,source ,target))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules2.scm,v 4.3 1989/05/17 20:31:04 jinx Rel $
-$MC68020-Header: rules2.scm,v 4.7 88/12/13 17:45:25 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules2.scm,v 4.4 1991/02/15 00:42:21 jinx Exp $
+$MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; LAP Generation Rules: Predicates. DEC VAX version.
-;;; Note: All fixnum code has been moved to rulfix.scm.
+;;;; LAP Generation Rules: Predicates.
+;;; Note: All fixnum code is in rulfix.scm.
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
-(define-rule predicate
- (TRUE-TEST (REGISTER (? register)))
- (set-standard-branches! 'NEQ)
- (LAP ,(test-non-pointer (ucode-type false)
- 0
- (standard-register-reference register false))))
-
-(define-rule predicate
- (TRUE-TEST (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (set-standard-branches! 'NEQ)
- (LAP ,(test-non-pointer (ucode-type false)
- 0
- (predicate/memory-operand-reference memory))))
-
(define-rule predicate
(TYPE-TEST (REGISTER (? register)) (? type))
- (QUALIFIER (pseudo-register? register))
(set-standard-branches! 'EQL)
- (LAP ,(test-byte type (reference-alias-register! register 'GENERAL))))
+ (test-byte type (reference-alias-register! register 'GENERAL)))
(define-rule predicate
(TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
- (QUALIFIER (pseudo-register? register))
- (set-standard-branches! 'EQL)
- (with-temporary-register-copy! register 'GENERAL
- (lambda (temp)
- (LAP (ROTL (S 8) ,temp ,temp)
- ,(test-byte type temp)))
- (lambda (source temp)
- (LAP (ROTL (S 8) ,source ,temp)
- ,(test-byte type temp)))))
-
-;; This is the split of a 68020 rule which seems wrong for post-increment.
-
-(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (OFFSET (REGISTER (? r)) (? offset))) (? type))
- (set-standard-branches! 'EQL)
- (LAP ,(test-byte type (indirect-byte-reference! r (+ 3 (* 4 offset))))))
-
-(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (POST-INCREMENT (REGISTER 14) 1)) (? type))
- (set-standard-branches! 'EQL)
- (let ((temp (reference-temporary-register! 'GENERAL)))
- (LAP (ROTL (S 8) (@R+ 14) ,temp)
- ,(test-byte type temp))))
-\f
-(define-rule predicate
- (UNASSIGNED-TEST (REGISTER (? register)))
- (set-standard-branches! 'EQL)
- (LAP ,(test-non-pointer (ucode-type unassigned)
- 0
- (standard-register-reference register false))))
+ (compare-type type (any-register-reference register)))
(define-rule predicate
- (UNASSIGNED-TEST (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (set-standard-branches! 'EQL)
- (LAP ,(test-non-pointer (ucode-type unassigned)
- 0
- (predicate/memory-operand-reference memory))))
-
-(define-rule predicate
- (OVERFLOW-TEST)
- (set-standard-branches! 'VS)
- (LAP))
+ (TYPE-TEST (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset)))
+ (? type))
+ (compare-type type (indirect-reference! address offset)))
(define-rule predicate
(EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
- (QUALIFIER (and (pseudo-register? register-1)
- (pseudo-register? register-2)))
(compare/register*register register-1 register-2 'EQL))
(define-rule predicate
(EQ-TEST (REGISTER (? register)) (? memory))
- (QUALIFIER (and (predicate/memory-operand? memory)
- (pseudo-register? register)))
+ (QUALIFIER (predicate/memory-operand? memory))
(compare/register*memory register
(predicate/memory-operand-reference memory)
'EQL))
(define-rule predicate
(EQ-TEST (? memory) (REGISTER (? register)))
- (QUALIFIER (and (predicate/memory-operand? memory)
- (pseudo-register? register)))
+ (QUALIFIER (predicate/memory-operand? memory))
(compare/register*memory register
(predicate/memory-operand-reference memory)
'EQL))
(compare/memory*memory (predicate/memory-operand-reference memory-1)
(predicate/memory-operand-reference memory-2)
'EQL))
-\f
-(define (eq-test/constant*register constant register)
- (if (non-pointer-object? constant)
- (begin
- (set-standard-branches! 'EQL)
- (LAP ,(test-non-pointer (object-type constant)
- (object-datum constant)
- (standard-register-reference register false))))
- (compare/register*memory register
- (INST-EA (@PCR ,(constant->label constant)))
- 'EQL)))
-
-(define (eq-test/constant*memory constant memory)
- (if (non-pointer-object? constant)
- (begin
- (set-standard-branches! 'EQL)
- (LAP ,(test-non-pointer (object-type constant)
- (object-datum constant)
- memory)))
- (compare/memory*memory memory
- (INST-EA (@PCR ,(constant->label constant)))
- 'EQL)))
(define-rule predicate
(EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
- (QUALIFIER (pseudo-register? register))
(eq-test/constant*register constant register))
(define-rule predicate
(EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
- (QUALIFIER (pseudo-register? register))
(eq-test/constant*register constant register))
(define-rule predicate
(EQ-TEST (CONSTANT (? constant)) (? memory))
(QUALIFIER (predicate/memory-operand? memory))
- (eq-test/constant*memory constant
- (predicate/memory-operand-reference memory)))
+ (eq-test/constant*memory constant memory))
(define-rule predicate
(EQ-TEST (? memory) (CONSTANT (? constant)))
(QUALIFIER (predicate/memory-operand? memory))
- (eq-test/constant*memory constant
- (predicate/memory-operand-reference memory)))
\ No newline at end of file
+ (eq-test/constant*memory constant memory))
+
+(define-rule predicate
+ (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (REGISTER (? register)))
+ (eq-test/synthesized-constant*register type datum register))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (eq-test/synthesized-constant*register type datum register))
+
+(define-rule predicate
+ (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (? memory))
+ (QUALIFIER (predicate/memory-operand? memory))
+ (eq-test/synthesized-constant*memory type datum memory))
+
+(define-rule predicate
+ (EQ-TEST (? memory)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (QUALIFIER (predicate/memory-operand? memory))
+ (eq-test/synthesized-constant*memory type datum memory))
+\f
+;;;; Utilities
+
+(define (eq-test/synthesized-constant type datum ea)
+ (set-standard-branches! 'EQL)
+ (test-non-pointer type datum ea))
+
+(define-integrable (eq-test/synthesized-constant*register type datum reg)
+ (eq-test/synthesized-constant type datum
+ (any-register-reference reg)))
+
+(define-integrable (eq-test/synthesized-constant*memory type datum memory)
+ (eq-test/synthesized-constant type datum
+ (predicate/memory-operand-reference memory)))
+
+(define (eq-test/constant*register constant register)
+ (if (non-pointer-object? constant)
+ (eq-test/synthesized-constant (object-type constant)
+ (careful-object-datum constant)
+ (any-register-reference register))
+ (compare/register*memory register
+ (INST-EA (@PCR ,(constant->label constant)))
+ 'EQL)))
+
+(define (eq-test/constant*memory constant memory)
+ (let ((memory (predicate/memory-operand-reference memory)))
+ (if (non-pointer-object? constant)
+ (eq-test/synthesized-constant (object-type constant)
+ (careful-object-datum constant)
+ memory)
+ (compare/memory*memory memory
+ (INST-EA (@PCR ,(constant->label constant)))
+ 'EQL))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules3.scm,v 4.7 1989/05/17 20:31:11 jinx Rel $
-$MC68020-Header: rules3.scm,v 4.15 88/12/30 07:05:20 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules3.scm,v 4.8 1991/02/15 00:42:30 jinx Exp $
+$MC68020-Header: rules3.scm,v 4.26 90/08/21 02:23:26 GMT jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; LAP Generation Rules: Invocations and Entries. DEC VAX version.
+;;;; LAP Generation Rules: Invocations and Entries.
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
;;;; Invocations
+(define-integrable (clear-continuation-type-code)
+ (LAP (BIC L ,mask-reference (@R 14))))
+
(define-rule statement
(POP-RETURN)
(LAP ,@(clear-map!)
- (CLR B (@RO B 14 3))
+ ,@(clear-continuation-type-code)
(RSB)))
(define-rule statement
(INVOCATION:APPLY (? frame-size) (? continuation))
continuation ; ignored
(LAP ,@(clear-map!)
- ,(load-rn frame-size 0)
- (JMP ,entry:compiler-apply)))
+ ,@(load-rn frame-size 2)
+ #|
+ (JMP ,entry:compiler-shortcircuit-apply)
+ |#
+ (MOV L (@R+ 14) (R 1))
+ ,@(invoke-interface code:compiler-apply)
+ ;; 'Til here
+ ))
(define-rule statement
(INVOCATION:JUMP (? frame-size) (? continuation) (? label))
frame-size continuation ; ignored
;; It expects the procedure at the top of the stack
(LAP ,@(clear-map!)
- (CLR B (@RO B 14 3))
+ ,@(clear-continuation-type-code)
(RSB)))
(define-rule statement
(INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
continuation ; ignored
(LAP ,@(clear-map!)
- ,(load-rn number-pushed 0)
- (MOVA B (@PCR ,label) (R 3))
- (JMP ,entry:compiler-lexpr-apply)))
+ ,@(load-rn number-pushed 2)
+ (MOVA B (@PCR ,label) (R 1))
+ ,@(invoke-interface code:compiler-lexpr-apply)))
(define-rule statement
(INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
continuation ; ignored
;; It expects the procedure at the top of the stack
(LAP ,@(clear-map!)
- ,(load-rn number-pushed 0)
- (BIC L ,mask-reference (@R+ 14) (R 3))
- (JMP ,entry:compiler-lexpr-apply)))
+ ,@(load-rn number-pushed 2)
+ (BIC L ,mask-reference (@R+ 14) (R 1))
+ ,@(invoke-interface code:compiler-lexpr-apply)))
(define-rule statement
(INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
;; The other possibility would be
;; (JMP (@@PCR ,(free-uuo-link-label name frame-size)))
;; and to have <entry> at label, but it is longer and slower.
- (BR (@PCR ,(free-uuo-link-label name frame-size)))))
+ ;; The 2 below accomodates the arrangement between the arity
+ ;; and the instructions in an execute cache.
+ (BR (@PCRO ,(free-uuo-link-label name frame-size) 2))))
+\f
+;;; The following two rules are obsolete. They haven't been used in a while.
+;;; They are provided in case the relevant switches are turned off, but there
+;;; is no reason to do this. Perhaps the switches should be removed.
(define-rule statement
(INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
continuation ; ignored
- (let ((set-extension (expression->machine-register! extension r6)))
- (delete-dead-registers!)
+ (let* ((set-extension
+ (interpreter-call-argument->machine-register! extension r1))
+ (clear-map (clear-map!)))
(LAP ,@set-extension
- ,@(clear-map!)
- ,(load-rn frame-size 0)
- (MOVA B (@PCR ,*block-start-label*) (R 4))
- (JMP ,entry:compiler-cache-reference-apply))))
+ ,@clear-map
+ ,@(load-rn frame-size 3)
+ (MOVA B (@PCR ,*block-label*) (R 2))
+ ,@(invoke-interface code:compiler-cache-reference-apply))))
(define-rule statement
(INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name))
continuation ; ignored
- (let ((set-environment (expression->machine-register! environment r7)))
- (delete-dead-registers!)
+ (let* ((set-environment
+ (interpreter-call-argument->machine-register! environment r1))
+ (clear-map (clear-map!)))
(LAP ,@set-environment
- ,@(clear-map!)
- ,(load-constant name (INST-EA (R 8)))
- ,(load-rn frame-size 0)
- (JMP ,entry:compiler-lookup-apply))))
+ ,@clear-map
+ ,@(load-constant name (INST-EA (R 2)))
+ ,@(load-rn frame-size 3)
+ ,@(invoke-interface code:compiler-lookup-apply))))
\f
(define-rule statement
(INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
continuation ; ignored
(LAP ,@(clear-map!)
,@(if (eq? primitive compiled-error-procedure)
- (LAP ,(load-rn frame-size 0)
- (JMP ,entry:compiler-error))
+ (LAP ,@(load-rn frame-size 1)
+ #|
+ (JMP ,entry:compiler-error)
+ |#
+ ,@(invoke-interface code:compiler-error))
(let ((arity (primitive-procedure-arity primitive)))
(cond ((not (negative? arity))
- (LAP (MOV L (@PCR ,(constant->label primitive)) (R 9))
- (JMP ,entry:compiler-primitive-apply)))
+ (LAP (MOV L (@PCR ,(constant->label primitive)) (R 1))
+ #|
+ (JMP ,entry:compiler-primitive-apply)
+ |#
+ ,@(invoke-interface code:compiler-primitive-apply)))
((= arity -1)
(LAP (MOV L ,(make-immediate (-1+ frame-size))
,reg:lexpr-primitive-arity)
- (MOV L (@PCR ,(constant->label primitive)) (R 9))
- (JMP ,entry:compiler-primitive-lexpr-apply)))
+ (MOV L (@PCR ,(constant->label primitive)) (R 1))
+ #|
+ (JMP ,entry:compiler-primitive-lexpr-apply)
+ |#
+ ,@(invoke-interface
+ code:compiler-primitive-lexpr-apply)))
(else
;; Unknown primitive arity. Go through apply.
- (LAP ,(load-rn frame-size 0)
- (PUSHL (@PCR ,(constant->label primitive)))
- (JMP ,entry:compiler-apply))))))))
+ (LAP ,@(load-rn frame-size 2)
+ (MOV L (constant->ea primitive) (R 1))
+ #|
+ (JMP ,entry:compiler-apply)
+ |#
+ ,@(invoke-interface code:compiler-apply))))))))
(let-syntax
((define-special-primitive-invocation
frame-size continuation ; ignored
,(list 'LAP
(list 'UNQUOTE-SPLICING '(clear-map!))
+ #|
(list 'JMP
(list 'UNQUOTE
- (symbol-append 'ENTRY:COMPILER- name))))))))
+ (symbol-append 'ENTRY:COMPILER- name)))
+ |#
+ (list 'UNQUOTE-SPLICING
+ `(INVOKE-INTERFACE ,(symbol-append 'CODE:COMPILER-
+ name))))))))
(define-special-primitive-invocation &+)
(define-special-primitive-invocation &-)
(define-special-primitive-invocation &*)
(LAP))
(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 10))
- (generate/move-frame-up frame-size (offset-reference 10 0)))
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 13))
+ (generate/move-frame-up frame-size (offset-reference 13 0)))
(define-rule statement
(INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
(cond ((zero? how-far)
(LAP))
((zero? frame-size)
- (increment-rn 14 how-far))
+ (increment-rn 14 (* 4 how-far)))
((= frame-size 1)
(LAP (MOV L (@R+ 14) ,(offset-reference r14 (-1+ how-far)))
- ,@(increment-rn 14 (-1+ how-far))))
+ ,@(increment-rn 14 (* 4 (-1+ how-far)))))
((= frame-size 2)
(if (= how-far 1)
(LAP (MOV L (@RO B 14 4) (@RO B 14 8))
(MOV L (@R+ 14) (@R 14)))
(let ((i (lambda ()
- (INST (MOV L (@R+ 14)
- ,(offset-reference r14 (-1+ how-far)))))))
- (LAP ,(i)
- ,(i)
- ,@(increment-rn 14 (- how-far 2))))))
+ (LAP (MOV L (@R+ 14)
+ ,(offset-reference r14 (-1+ how-far)))))))
+ (LAP ,@(i)
+ ,@(i)
+ ,@(increment-rn 14 (* 4 (- how-far 2)))))))
(else
(generate/move-frame-up frame-size
(offset-reference r14 offset))))))
(generate/move-frame-up frame-size (indirect-reference! base offset)))
\f
(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 14) (REGISTER 10))
+ (INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 14) (REGISTER 13))
(LAP))
(define-rule statement
(INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
(OFFSET-ADDRESS (REGISTER (? base))
(? offset))
- (REGISTER 10))
+ (REGISTER 13))
(let ((label (generate-label))
(temp (allocate-temporary-register! 'GENERAL)))
(let ((temp-ref (register-reference temp)))
(LAP (MOVA L ,(indirect-reference! base offset) ,temp-ref)
- (CMP L ,temp-ref (R 10))
+ (CMP L ,temp-ref (R 13))
(B B LEQU (@PCR ,label))
- (MOV L (R 10) ,temp-ref)
+ (MOV L (R 13) ,temp-ref)
(LABEL ,label)
,@(generate/move-frame-up* frame-size temp)))))
(define-rule statement
(INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
(OBJECT->ADDRESS (REGISTER (? source)))
- (REGISTER 10))
+ (REGISTER 13))
(QUALIFIER (pseudo-register? source))
(let ((do-it
(lambda (reg-ref)
(let ((label (generate-label)))
- (LAP (CMP L ,reg-ref (R 10))
+ (LAP (CMP L ,reg-ref (R 13))
(B B LEQU (@PCR ,label))
- (MOV L (R 10) ,reg-ref)
+ (MOV L (R 13) ,reg-ref)
(LABEL ,label)
,@(generate/move-frame-up* frame-size
(lap:ea-R-register reg-ref)))))))
(define-rule statement
(INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
(REGISTER (? source))
- (REGISTER 10))
+ (REGISTER 13))
(QUALIFIER (pseudo-register? source))
(let ((reg-ref (move-to-temporary-register! source 'GENERAL))
(label (generate-label)))
- (LAP (CMP L ,reg-ref (R 10))
+ (LAP (CMP L ,reg-ref (R 13))
(B B LEQU (@PCR ,label))
- (MOV L (R 10) ,reg-ref)
+ (MOV L (R 13) ,reg-ref)
(LABEL ,label)
,@(generate/move-frame-up* frame-size
(lap:ea-R-register reg-ref)))))
,@(generate-n-times
frame-size 5
(lambda ()
- (INST (MOV L
- (@-R ,temp)
- (@-R ,destination))))
+ (LAP (MOV L (@-R ,temp) (@-R ,destination))))
(lambda (generator)
(generator (allocate-temporary-register! 'GENERAL))))
(MOV L ,(register-reference destination) (R 14)))))
;;;; External Labels
(define (make-external-label code label)
- (set! compiler:external-labels
- (cons label compiler:external-labels))
+ (set! *external-labels* (cons label *external-labels*))
(LAP (WORD U ,code)
(BLOCK-OFFSET ,label)
(LABEL ,label)))
;;; Entry point types
+(define-integrable (make-format-longword format-word gc-offset)
+ (+ (* #x20000 gc-offset) format-word))
+
(define-integrable (make-code-word min max)
(+ (* #x100 min) 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)
- (let ((offset
- (if label
- (rtl-continuation/next-continuation-offset (label->object label))
- 0)))
- (cond ((not offset)
- (make-code-word #xff #xfc))
- ((< offset #x2000)
- ;; This uses up through (#xff #xdf).
- (let ((qr (integer-divide offset #x80)))
- (make-code-word (+ #x80 (integer-divide-remainder qr))
- (+ #x80 (integer-divide-quotient qr)))))
- (else
- (error "Unable to encode continuation offset" offset)))))
+ (frame-size->code-word
+ (if label
+ (rtl-continuation/next-continuation-offset (label->object label))
+ 0)
+ internal-continuation-code-word))
+
+(define (internal-procedure-code-word rtl-proc)
+ (frame-size->code-word
+ (rtl-procedure/next-continuation-offset rtl-proc)
+ internal-entry-code-word))
\f
;;;; Procedure headers
;;; The following calls MUST appear as the first thing at the entry
;;; point of a procedure. They assume that the register map is clear
;;; and that no register contains anything of value.
-
-;;; **** The only reason that this is true is that no register is live
+;;;
+;;; The only reason that this is true is that no register is live
;;; across calls. If that were not true, then we would have to save
;;; any such registers on the stack so that they would be GC'ed
;;; appropriately.
;;;
-;;; **** This is not strictly true: the dynamic link register may
-;;; contain a valid dynamic link, but the gc handler determines that
-;;; and saves it as appropriate.
+;;; 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-integrable (simple-procedure-header code-word label
- entry:compiler-interrupt)
+ ;; entry:compiler-interrupt
+ code:compiler-interrupt)
(let ((gc-label (generate-label)))
(LAP (LABEL ,gc-label)
+ #|
(JSB ,entry:compiler-interrupt)
+ |#
+ ,@(invoke-interface-jsb code:compiler-interrupt)
+ ,@(make-external-label code-word label)
+ (CMP L (R 12) ,reg:compiled-memtop)
+ (B B GEQ (@PCR ,gc-label)))))
+
+(define (dlink-procedure-header code-word label)
+ (let ((gc-label (generate-label)))
+ (LAP (LABEL ,gc-label)
+ #|
+ (JSB ,entry:compiler-interrupt-dlink)
+ |#
+ (MOV L (R 13) (R 2)) ; move dlink to arg register.
+ ,@(invoke-interface-jsb code:compiler-interrupt-dlink)
+ ;; 'Til here
,@(make-external-label code-word label)
(CMP L (R 12) ,reg:compiled-memtop)
(B B GEQ (@PCR ,gc-label)))))
(CONTINUATION-HEADER (? internal-label))
(simple-procedure-header (continuation-code-word internal-label)
internal-label
- entry:compiler-interrupt-continuation))
+ ;; entry:compiler-interrupt-continuation
+ code:compiler-interrupt-continuation))
(define-rule statement
(IC-PROCEDURE-HEADER (? internal-label))
- (let ((procedure (label->object internal-label)))
- (let ((external-label (rtl-procedure/external-label procedure)))
+ (let* ((procedure (label->object internal-label))
+ (external-label (rtl-procedure/external-label procedure)))
(LAP (ENTRY-POINT ,external-label)
(EQUATE ,external-label ,internal-label)
,@(simple-procedure-header expression-code-word
internal-label
- entry:compiler-interrupt-ic-procedure)))))
+ ;; entry:compiler-interrupt-ic-procedure
+ code:compiler-interrupt-ic-procedure))))
(define-rule statement
(OPEN-PROCEDURE-HEADER (? internal-label))
- (LAP (EQUATE ,(rtl-procedure/external-label
- (label->object internal-label))
- ,internal-label)
- ,@(simple-procedure-header internal-entry-code-word
- internal-label
- entry:compiler-interrupt-procedure)))
+ (let ((rtl-proc (label->object internal-label)))
+ (LAP
+ (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
+ ,@((if (rtl-procedure/dynamic-link? rtl-proc)
+ dlink-procedure-header
+ (lambda (code-word label)
+ (simple-procedure-header code-word label
+ ;; entry:compiler-interrupt-procedure
+ code:compiler-interrupt-procedure)))
+ (internal-procedure-code-word rtl-proc)
+ internal-label))))
(define-rule statement
(PROCEDURE-HEADER (? internal-label) (? min) (? max))
,internal-label)
,@(simple-procedure-header (make-procedure-code-word min max)
internal-label
- entry:compiler-interrupt-procedure)))
+ ;; entry:compiler-interrupt-procedure
+ code:compiler-interrupt-procedure)))
\f
;;;; Closures. These two statements are intertwined:
+;;; Note: If the closure is a multiclosure, the closure object on the
+;;; stack corresponds to the first (official) entry point.
+;;; Thus on entry and interrupt it must be bumped around.
-(define magic-closure-constant
- (- (* (ucode-type compiled-entry) #x1000000) 6))
+(define (make-magic-closure-constant entry)
+ (- (make-non-pointer-literal (ucode-type compiled-entry) 0)
+ (+ (* entry 10) 6)))
(define-rule statement
- (CLOSURE-HEADER (? internal-label))
- (let ((procedure (label->object internal-label)))
+ (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+ nentries ; ignored
+ (let ((rtl-proc (label->object internal-label)))
(let ((gc-label (generate-label))
- (external-label (rtl-procedure/external-label procedure)))
- (LAP (LABEL ,gc-label)
- (JMP ,entry:compiler-interrupt-closure)
- ,@(make-external-label internal-entry-code-word external-label)
- (ADD L (& ,magic-closure-constant) (@R 14))
- (LABEL ,internal-label)
- (CMP L (R 12) ,reg:compiled-memtop)
- (B B GEQ (@PCR ,gc-label))))))
+ (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
+ code:compiler-interrupt-procedure))
+ (LAP (LABEL ,gc-label)
+ ,@(increment/ea (INST-EA (@R 14)) (* 10 entry))
+ #|
+ (JMP ,entry:compiler-interrupt-closure)
+ |#
+ ,@(invoke-interface code:compiler-interrupt-closure)
+ ,@(make-external-label internal-entry-code-word
+ external-label)
+ (ADD L (&U ,(make-magic-closure-constant entry)) (@R 14))
+ (LABEL ,internal-label)
+ (CMP L (R 12) ,reg:compiled-memtop)
+ (B B GEQ (@PCR ,gc-label)))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (CONS-POINTER (CONSTANT (? type))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size))))
- (QUALIFIER (pseudo-register? target))
- (generate/cons-closure (reference-target-alias! target 'GENERAL)
- type procedure-label min max size))
-
-(define-rule statement
- (ASSIGN (? target)
- (CONS-POINTER (CONSTANT (? type))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size))))
- (QUALIFIER (standard-target-expression? target))
- (generate/cons-closure
- (standard-target-expression->ea target)
- type procedure-label min max size))
+ (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+ (? min) (? max) (? size)))
+ (let ((target (standard-target-reference target)))
+ (generate/cons-closure target
+ false procedure-label min max size)))
(define (generate/cons-closure target type procedure-label min max size)
- (LAP ,(load-non-pointer (ucode-type manifest-closure)
- (+ 3 size)
- (INST-EA (@R+ 12)))
- (MOV L (&U ,(+ #x100000 (make-procedure-code-word min max)))
+ (LAP ,@(load-non-pointer (ucode-type manifest-closure)
+ (+ 3 size)
+ (INST-EA (@R+ 12)))
+ (MOV L (&U ,(make-format-longword (make-procedure-code-word min max) 8))
(@R+ 12))
- (BIS L (& ,(make-non-pointer-literal type 0)) (R 12) ,target)
+ ,@(if type
+ (LAP (BIS L (&U ,(make-non-pointer-literal type 0)) (R 12)
+ ,target))
+ (LAP (MOV L (R 12) ,target)))
(MOV W (&U #x9f16) (@R+ 12)) ; (JSB (@& <entry>))
(MOVA B (@PCR ,(rtl-procedure/external-label
(label->object procedure-label)))
(@R+ 12))
(CLR W (@R+ 12))
- ,@(increment-rn 12 size)))
+ ,@(increment-rn 12 (* 4 size))))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+ (let ((target (standard-target-reference target)))
+ (case nentries
+ ((0)
+ (LAP (MOV L (R 12) ,target)
+ ,@(load-non-pointer (ucode-type manifest-vector)
+ size
+ (INST-EA (@R+ 12)))
+ ,@(increment-rn 12 (* 4 size))))
+ ((1)
+ (let ((entry (vector-ref entries 0)))
+ (generate/cons-closure target false
+ (car entry) (cadr entry) (caddr entry)
+ size)))
+ (else
+ (generate/cons-multiclosure target nentries size
+ (vector->list entries))))))
+
+(define (generate/cons-multiclosure target nentries size entries)
+ (let ((total-size (+ size
+ (quotient (+ 3 (* 5 nentries))
+ 2)))
+ (temp (standard-temporary-reference)))
+
+ (define (generate-entries entries offset first?)
+ (if (null? entries)
+ (LAP)
+ (let ((entry (car entries)))
+ (LAP (MOV L (&U ,(make-format-longword
+ (make-procedure-code-word (cadr entry)
+ (caddr entry))
+ offset))
+ (@R+ 12))
+ ,@(if first?
+ (LAP (MOV L (R 12) ,target))
+ (LAP))
+ (MOV W ,temp (@R+ 12)) ; (JSB (@& <entry>))
+ (MOVA B (@PCR ,(rtl-procedure/external-label
+ (label->object (car entry))))
+ (@R+ 12))
+ ,@(generate-entries (cdr entries)
+ (+ 10 offset)
+ false)))))
+
+ (LAP ,@(load-non-pointer (ucode-type manifest-closure)
+ total-size
+ (INST-EA (@R+ 12)))
+ (MOV L (&U ,(make-format-longword nentries 0)) (@R+ 12))
+ (MOV W (&U #x9f16) ,temp)
+ ,@(generate-entries entries 12 true)
+ ,@(if (odd? nentries)
+ (LAP (CLR W (@R+ 12)))
+ (LAP))
+ ,@(increment-rn 12 (* 4 size)))))
\f
;;;; Entry Header
;;; This is invoked by the top level of the LAP GENERATOR.
-(define generate/quotation-header
- (let ((uuo-link-tag 0)
- (reference-tag 1)
- (assignment-tag 2))
-
- (define (make-constant-block-tag tag datum)
- (if (> datum #xffff)
- (error "make-constant-block-tag: datum too large" datum)
- (+ (* tag #x10000) datum)))
-
- (define (declare-constants tag constants info)
- (define (inner constants)
- (if (null? constants)
- (cdr info)
- (let ((entry (car constants)))
- (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
- ,@(inner (cdr constants))))))
-
- (if (and tag (not (null? constants)))
- (let ((label (allocate-constant-label)))
- (cons label
- (inner `((,(make-constant-block-tag tag (length constants))
- . ,label)
- ,@constants))))
- (cons (car info) (inner constants))))
-
- (define (transmogrifly uuos)
- (define (inner name assoc)
- (if (null? assoc)
- (transmogrifly (cdr uuos))
- (cons (cons name (cdar assoc)) ; uuo-label
- (cons (cons (caar assoc) ; frame-size
- (allocate-constant-label))
- (inner name (cdr assoc))))))
- (if (null? uuos)
- '()
- (inner (caar uuos) (cdar uuos))))
-
- (lambda (block-label constants references assignments uuo-links)
- (let ((constant-info
- (declare-constants uuo-link-tag (transmogrifly uuo-links)
- (declare-constants reference-tag references
- (declare-constants assignment-tag assignments
- (declare-constants #f constants
- (cons '() (LAP))))))))
- (let ((free-ref-label (car constant-info))
- (constants-code (cdr constant-info))
- (debugging-information-label (allocate-constant-label))
- (environment-label (allocate-constant-label)))
- (LAP ,@constants-code
- ;; Place holder for the debugging info filename
- (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
- ;; Place holder for the load time environment if needed
- (SCHEME-OBJECT ,environment-label
- ,(if (null? free-ref-label) 0 'ENVIRONMENT))
- ,@(if (null? free-ref-label)
- (LAP)
- (LAP (MOV L ,reg:environment (@PCR ,environment-label))
- (MOVA B (@PCR ,block-label) (R 3))
- (MOVA B (@PCR ,free-ref-label) (R 4))
- ,(load-rn (+ (if (null? uuo-links) 0 1)
- (if (null? references) 0 1)
- (if (null? assignments) 0 1))
- 0)
- (JSB ,entry:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))))))))
+(define (generate/quotation-header environment-label free-ref-label n-sections)
+ (LAP (MOV L ,reg:environment (@PCR ,environment-label))
+ (MOVA B (@PCR ,*block-label*) (R 2))
+ (MOVA B (@PCR ,free-ref-label) (R 3))
+ ,@(load-rn n-sections 4)
+ #|
+ (JSB ,entry:compiler-link)
+ |#
+ ,@(invoke-interface-jsb code:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))
+
+(define (generate/remote-link code-block-label
+ environment-offset
+ free-ref-offset
+ n-sections)
+ (LAP (BIC L ,mask-reference (@PCR ,code-block-label) (R 2))
+ (MOV L ,reg:environment
+ (@RO ,(datum-size environment-offset) 2 ,environment-offset))
+ ,@(add-constant/ea (INST-EA (R 2)) free-ref-offset (INST-EA (R 3)))
+ ,@(load-rn n-sections 4)
+ #|
+ (JSB ,entry:compiler-link)
+ |#
+ ,@(invoke-interface-jsb code:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))
+\f
+(define (generate/constants-block constants references assignments uuo-links)
+ (let ((constant-info
+ (declare-constants 0 (transmogrifly uuo-links)
+ (declare-constants 1 references
+ (declare-constants 2 assignments
+ (declare-constants false constants
+ (cons false (LAP))))))))
+ (let ((free-ref-label (car constant-info))
+ (constants-code (cdr constant-info))
+ (debugging-information-label (allocate-constant-label))
+ (environment-label (allocate-constant-label))
+ (n-sections
+ (+ (if (null? uuo-links) 0 1)
+ (if (null? references) 0 1)
+ (if (null? assignments) 0 1))))
+ (values
+ (LAP ,@constants-code
+ ;; Place holder for the debugging info filename
+ (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
+ ;; Place holder for the load time environment if needed
+ (SCHEME-OBJECT ,environment-label
+ ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
+ environment-label
+ free-ref-label
+ n-sections))))
+
+(define (declare-constants tag constants info)
+ (define (inner constants)
+ (if (null? constants)
+ (cdr info)
+ (let ((entry (car constants)))
+ (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
+ ,@(inner (cdr constants))))))
+ (if (and tag (not (null? constants)))
+ (let ((label (allocate-constant-label)))
+ (cons label
+ (inner
+ `((,(let ((datum (length constants)))
+ (if (> datum #xffff)
+ (error "datum too large" datum))
+ (+ (* tag #x10000) datum))
+ . ,label)
+ ,@constants))))
+ (cons (car info) (inner constants))))
+
+;; 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
+;; Vax is little-endian). The invocation rule for uuo-links has been
+;; changed to take the extra 2 bytes into account.
+;; Alternatively we could
+;; make execute caches 3 words long, with the third containing the
+;; frame size and the middle the second part of the instruction.
+
+(define (transmogrifly uuos)
+ (define (inner name assoc)
+ (if (null? assoc)
+ (transmogrifly (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))))
\f
;;; Local Variables: ***
;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules4.scm,v 4.2 1989/05/17 20:31:24 jinx Rel $
-$MC68020-Header: rules4.scm,v 4.5 88/12/30 07:05:28 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules4.scm,v 4.3 1991/02/15 00:42:38 jinx Exp $
+$MC68020-Header: rules4.scm,v 4.12 90/05/03 15:17:38 GMT jinx Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; LAP Generation Rules: Interpreter Calls. DEC VAX version.
+;;;; LAP Generation Rules: Interpreter Calls.
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
-;;;; Interpreter Calls
-
-(define-rule statement
- (INTERPRETER-CALL:ACCESS (? environment) (? name))
- (lookup-call entry:compiler-access environment name))
+;;;; Variable cache trap handling.
(define-rule statement
- (INTERPRETER-CALL:LOOKUP (? environment) (? name) (? safe?))
- (lookup-call (if safe? entry:compiler-safe-lookup entry:compiler-lookup)
- environment name))
+ (INTERPRETER-CALL:CACHE-REFERENCE (? extension) (? safe?))
+ (QUALIFIER (interpreter-call-argument? extension))
+ (let* ((set-extension
+ (interpreter-call-argument->machine-register! extension r2))
+ (clear-map (clear-map!)))
+ (LAP ,@set-extension
+ ,@clear-map
+ #|
+ ;; This should be enabled if the short-circuit code is written.
+ (JSB ,(if safe?
+ entry:compiler-safe-reference-trap
+ entry:compiler-reference-trap))
+ |#
+ ,@(invoke-interface-jsb (if safe?
+ code:compiler-safe-reference-trap
+ code:compiler-reference-trap)))))
(define-rule statement
- (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name))
- (lookup-call entry:compiler-unassigned? environment name))
+ (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (? value))
+ (QUALIFIER (and (interpreter-call-argument? extension)
+ (interpreter-call-argument? value)))
+ (let* ((set-extension
+ (interpreter-call-argument->machine-register! extension r2))
+ (set-value (interpreter-call-argument->machine-register! value r3))
+ (clear-map (clear-map!)))
+ (LAP ,@set-extension
+ ,@set-value
+ ,@clear-map
+ #|
+ ;; This should be enabled if the short-circuit code is written.
+ (JSB ,entry:compiler-assignment-trap)
+ |#
+ ,@(invoke-interface-jsb code:compiler-assignment-trap))))
(define-rule statement
- (INTERPRETER-CALL:UNBOUND? (? environment) (? name))
- (lookup-call entry:compiler-unbound? environment name))
-
-(define (lookup-call entry environment name)
- (let ((set-environment (expression->machine-register! environment r4)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-environment
- ,@clear-map
- ,(load-constant name (INST-EA (R 4)))
- (JSB ,entry)))))
+ (INTERPRETER-CALL:CACHE-UNASSIGNED? (? extension))
+ (QUALIFIER (interpreter-call-argument? extension))
+ (let* ((set-extension
+ (interpreter-call-argument->machine-register! extension r2))
+ (clear-map (clear-map!)))
+ (LAP ,@set-extension
+ ,@clear-map
+ ,@(invoke-interface-jsb code:compiler-unassigned?-trap))))
\f
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value))
- (QUALIFIER (not (eq? 'CONS-POINTER (car value))))
- (assignment-call:default entry:compiler-define environment name value))
+;;;; Interpreter Calls
-(define-rule statement
- (INTERPRETER-CALL:SET! (? environment) (? name) (? value))
- (QUALIFIER (not (eq? 'CONS-POINTER (car value))))
- (assignment-call:default entry:compiler-set! environment name value))
-
-(define (assignment-call:default entry environment name value)
- (let ((set-environment (expression->machine-register! environment r3)))
- (let ((set-value (expression->machine-register! value r5)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-environment
- ,@set-value
- ,@clear-map
- ,(load-constant name (INST-EA (R 4)))
- (JSB ,entry))))))
+;;; 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:DEFINE (? environment) (? name)
- (CONS-POINTER (CONSTANT (? type))
- (REGISTER (? datum))))
- (assignment-call:cons-pointer entry:compiler-define environment name type
- datum))
+ (INTERPRETER-CALL:ACCESS (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ (lookup-call code:compiler-access environment name))
(define-rule statement
- (INTERPRETER-CALL:SET! (? environment) (? name)
- (CONS-POINTER (CONSTANT (? type))
- (REGISTER (? datum))))
- (assignment-call:cons-pointer entry:compiler-set! environment name type
- datum))
-
-(define (assignment-call:cons-pointer entry environment name type datum)
- (let ((set-environment (expression->machine-register! environment r3)))
- (let ((datum (coerce->any datum)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-environment
- ,@clear-map
- (BIS L (& ,(make-non-pointer-literal type 0)) ,datum (R 5))
- ,(load-constant name (INST-EA (R 4)))
- (JSB ,entry))))))
+ (INTERPRETER-CALL:LOOKUP (? environment) (? name) (? safe?))
+ (QUALIFIER (interpreter-call-argument? environment))
+ (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
+ environment name))
(define-rule statement
- (INTERPRETER-CALL:DEFINE (? environment) (? name)
- (CONS-POINTER (CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (assignment-call:cons-procedure entry:compiler-define environment name type
- label))
+ (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ (lookup-call code:compiler-unassigned? environment name))
(define-rule statement
- (INTERPRETER-CALL:SET! (? environment) (? name)
- (CONS-POINTER (CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (assignment-call:cons-procedure entry:compiler-set! environment name type
- label))
-
-(define (assignment-call:cons-procedure entry environment name type label)
- (let ((set-environment (expression->machine-register! environment r3)))
- (LAP ,@set-environment
- ,@(clear-map!)
- (PUSHA B (@PCR ,(rtl-procedure/external-label (label->object label))))
- (MOV B ,(make-immediate type) (@RO B 14 3))
- (MOV L (@R+ 14) (R 5))
- ,(load-constant name (INST-EA (R 4)))
- (JSB ,entry))))
-\f
-(define-rule statement
- (INTERPRETER-CALL:CACHE-REFERENCE (? extension) (? safe?))
- (let ((set-extension (expression->machine-register! extension r3)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@clear-map
- (JSB ,(if safe?
- entry:compiler-safe-reference-trap
- entry:compiler-reference-trap))))))
+ (INTERPRETER-CALL:UNBOUND? (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ (lookup-call code:compiler-unbound? environment name))
-(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (? value))
- (QUALIFIER (not (eq? 'CONS-POINTER (car value))))
- (let ((set-extension (expression->machine-register! extension r3)))
- (let ((set-value (expression->machine-register! value r4)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@set-value
- ,@clear-map
- (JSB ,entry:compiler-assignment-trap))))))
+(define (lookup-call code environment name)
+ (let* ((set-environment
+ (interpreter-call-argument->machine-register! environment r2))
+ (clear-map (clear-map!)))
+ (LAP ,@set-environment
+ ,@clear-map
+ ,@(load-constant name (INST-EA (R 3)))
+ ,@(invoke-interface-jsb code))))
(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension)
- (CONS-POINTER (CONSTANT (? type))
- (REGISTER (? datum))))
- (let ((set-extension (expression->machine-register! extension r3)))
- (let ((datum (coerce->any datum)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@clear-map
- (BIS L (& ,(make-non-pointer-literal type 0)) ,datum (R 4))
- (JSB ,entry:compiler-assignment-trap))))))
+ (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value))
+ (QUALIFIER (and (interpreter-call-argument? environment)
+ (interpreter-call-argument? value)))
+ (assignment-call code:compiler-define environment name value))
(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT
- (? extension)
- (CONS-POINTER (CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (let* ((set-extension (expression->machine-register! extension r3))
+ (INTERPRETER-CALL:SET! (? environment) (? name) (? value))
+ (QUALIFIER (and (interpreter-call-argument? environment)
+ (interpreter-call-argument? value)))
+ (assignment-call code:compiler-set! environment name value))
+
+(define (assignment-call code environment name value)
+ (let* ((set-environment
+ (interpreter-call-argument->machine-register! environment r2))
+ (set-value (interpreter-call-argument->machine-register! value r4))
(clear-map (clear-map!)))
- (LAP ,@set-extension
+ (LAP ,@set-environment
+ ,@set-value
,@clear-map
- (PUSHA B (@PCR ,(rtl-procedure/external-label (label->object label))))
- (MOV B ,(make-immediate type) (@RO B 14 3))
- (MOV L (@R+ 14) (R 4))
- (JSB ,entry:compiler-assignment-trap))))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-UNASSIGNED? (? extension))
- (let ((set-extension (expression->machine-register! extension r3)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@clear-map
- (JSB ,entry:compiler-unassigned?-trap)))))
\ No newline at end of file
+ ,@(load-constant name (INST-EA (R 3)))
+ ,@(invoke-interface-jsb code))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rulfix.scm,v 1.2 1989/12/20 22:42:20 cph Rel $
-$MC68020-Header: rules1.scm,v 4.22 89/04/27 20:06:32 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rulfix.scm,v 1.3 1991/02/15 00:40:35 jinx Exp $
+$MC68020-Header: rules1.scm,v 4.34 1991/01/23 21:34:30 jinx Exp $
-Copyright (c) 1989 Massachusetts Institute of Technology
+Copyright (c) 1989, 1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; LAP Generation Rules: Fixnum operations. DEC VAX version.
-
-;;; Note: This corresponds to part of rules1 for MC68020.
-;;; Hopefully the MC68020 version will be split along the
-;;; same lines.
+;;;; LAP Generation Rules: Fixnum operations.
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
-;;;; Utilities
-
-(define-integrable (standard-fixnum-reference reg)
- (standard-register-reference reg false))
-
-(define (signed-fixnum? n)
- (and (integer? n)
- (>= n signed-fixnum/lower-limit)
- (< n signed-fixnum/upper-limit)))
-
-(define (unsigned-fixnum? n)
- (and (integer? n)
- (not (negative? n))
- (< n unsigned-fixnum/upper-limit)))
-
-(define (guarantee-signed-fixnum n)
- (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
- n)
-
-(define (guarantee-unsigned-fixnum n)
- (if (not (unsigned-fixnum? n)) (error "Not a unsigned fixnum" n))
- n)
-
-(define (load-fixnum-constant constant register-reference)
- (cond ((zero? constant)
- (INST (CLR L ,register-reference)))
- ((and (positive? constant) (< constant 64))
- (INST (ASH L (S 8) (S ,constant) ,register-reference)))
- (else
- (let* ((constant (* constant #x100))
- (size (datum-size constant)))
- (cond ((not (eq? size 'L))
- (INST (CVT ,size L (& ,constant) ,register-reference)))
- ((and (positive? constant) (< constant #x10000))
- (INST (MOVZ W L (& ,constant) ,register-reference)))
- (else
- (INST (MOV L (& ,constant) ,register-reference))))))))
-
-(define (test-fixnum effective-address)
- (INST (TST L ,effective-address)))
-
-(define (fixnum-predicate->cc predicate)
- (case predicate
- ((EQUAL-FIXNUM? ZERO-FIXNUM?) 'EQL)
- ((LESS-THAN-FIXNUM? NEGATIVE-FIXNUM?) 'LSS)
- ((GREATER-THAN-FIXNUM? POSITIVE-FIXNUM?) 'GTR)
- (else (error "FIXNUM-PREDICATE->CC: Unknown predicate" predicate))))
-
-(define (fixnum-operation-target? target)
- (or (rtl:register? target)
- (rtl:offset? target)))
-\f
-;;;; Fixnum operation dispatch
-
-(define (define-fixnum-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-fixnum-method operator methods)
- (cdr (or (assq operator (cdr methods))
- (error "Unknown operator" operator))))
-
-(define fixnum-methods/1-arg
- (list 'FIXNUM-METHODS/1-ARG))
-
-(define-integrable (fixnum-1-arg/operate operator)
- (lookup-fixnum-method operator fixnum-methods/1-arg))
-
-(define fixnum-methods/2-args
- (list 'FIXNUM-METHODS/2-ARGS))
-
-(define-integrable (fixnum-2-args/operate operator)
- (lookup-fixnum-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-fixnum-method operator fixnum-methods/2-args-constant))
-
-(define fixnum-methods/2-args-tnatsnoc
- (list 'FIXNUM-METHODS/2-ARGS-TNATSNOC))
-
-(define-integrable (fixnum-2-args/operate-tnatsnoc operator)
- (lookup-fixnum-method operator fixnum-methods/2-args-tnatsnoc))
-
-(define-integrable (fixnum-2-args/commutative? operator)
- (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
-\f
-;;;; Data conversion
-
-(define-integrable (object->fixnum source reg-ref)
- (LAP (ASH L (S 8) ,source ,reg-ref)))
-
-(define-integrable (ct/object->fixnum object target)
- (LAP ,(load-fixnum-constant object target)))
-
-(define-integrable (address->fixnum source reg-ref)
- (LAP (ASH L (S 8) ,source ,reg-ref)))
-
-(define-integrable (ct/address->fixnum address target)
- (LAP ,(load-fixnum-constant (object-datum address) target)))
-
-(define-integrable (fixnum->address source reg-ref)
- ;; This assumes that the low bits have 0s.
- (LAP (ROTL (& -8) ,source ,reg-ref)))
-
-(define-integrable (ct/fixnum->address fixnum target)
- (LAP ,(load-immediate fixnum target)))
-
-(define (fixnum->object source reg-ref target)
- (if (eq? source reg-ref)
- (LAP (MOV B (S ,(ucode-type fixnum)) ,reg-ref)
- (ROTL (& -8) ,reg-ref ,target))
- ;; This assumes that the low 8 bits are 0
- (LAP (BIS L (S ,(ucode-type fixnum)) ,source ,reg-ref)
- (ROTL (& -8) ,reg-ref ,target))))
-
-(define-integrable (ct/fixnum->object fixnum target)
- (LAP ,(load-constant fixnum target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (CONSTANT (? constant)))))
- (QUALIFIER (pseudo-register? target))
- (convert-object/constant->register target constant
- address->fixnum
- ct/address->fixnum))
+;;;; Making and examining fixnums
(define-rule statement
(ASSIGN (REGISTER (? target))
(ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
- (QUALIFIER (pseudo-register? target))
(convert-object/register->register target source address->fixnum))
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (OFFSET (REGISTER (? address))
- (? offset)))))
- (QUALIFIER (pseudo-register? target))
- (convert-object/offset->register target address offset address->fixnum))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
- (QUALIFIER (pseudo-register? target))
- (load-fixnum-constant constant (standard-target-reference target)))
-
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
(convert-object/register->register target source object->fixnum))
(define-rule statement
(ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
(convert-object/register->register target source address->fixnum))
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset))))
- (QUALIFIER (pseudo-register? target))
- (convert-object/offset->register target address offset object->fixnum))
-
(define-rule statement
(ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (convert-object/register->register
- target source
- (lambda (source target)
- (fixnum->object source target target))))
+ (convert-object/register->register target source fixnum->object))
(define-rule statement
(ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
(convert-object/register->register target source fixnum->address))
-(define (register-fixnum->temp->object reg target)
- (with-temporary-register-copy! reg 'GENERAL
- (lambda (temp)
- (fixnum->object temp temp target))
- (lambda (source temp)
- (fixnum->object source temp target))))
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (CONSTANT (? constant)))))
+ (convert-object/constant->register target constant
+ address->fixnum ct/address->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (load-fixnum-constant constant (standard-target-reference target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM
+ (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset)))))
+ (convert-object/offset->register target address offset address->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset))))
+ (convert-object/offset->register target address offset object->fixnum))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(FIXNUM->OBJECT (REGISTER (? source))))
- (let ((target (indirect-reference! a n)))
- (register-fixnum->temp->object source target)))
+ (let* ((source (any-register-reference source))
+ (target (indirect-reference! a n)))
+ (fixnum->object source target)))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 12) 1)
(FIXNUM->OBJECT (REGISTER (? r))))
- (register-fixnum->temp->object r (INST-EA (@R+ 12))))
+ (fixnum->object/temp r
+ (lambda (temp)
+ (LAP (MOV L ,temp (@R+ 12))))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
(FIXNUM->OBJECT (REGISTER (? r))))
- (register-fixnum->temp->object r (INST-EA (@-R 14))))
-\f
-;;;; Arithmetic operations
-
-(define-fixnum-method 'PLUS-FIXNUM fixnum-methods/2-args
- (lambda (target source1 source2)
- (cond ((eq? source1 target)
- (LAP (ADD L ,source2 ,target)))
- ((eq? source2 target)
- (LAP (ADD L ,source1 ,target)))
- (else
- (LAP (ADD L ,source1 ,source2 ,target))))))
-
-(define-fixnum-method 'PLUS-FIXNUM fixnum-methods/2-args-constant
- (lambda (target source n)
- (cond ((eq? source target)
- (if (zero? n)
- (LAP)
- (LAP (ADD L (& ,(* n #x100)) ,target))))
- ((zero? n)
- (LAP (MOV L ,source ,target)))
- (else
- (LAP (ADD L (& ,(* n #x100)) ,source ,target))))))
-
-(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
- (lambda (target source1 source2)
- (cond ((eq? source1 target)
- (if (equal? source1 source2)
- (LAP (ASH L (& -4) ,target ,target)
- (MUL L ,target ,target))
- (LAP (ASH L (& -8) ,target ,target)
- (MUL L ,source2 ,target))))
- ((eq? source2 target)
- (LAP (ASH L (& -8) ,target ,target)
- (MUL L ,source1 ,target)))
- (else
- (LAP (ASH L (& -8) ,source1 ,target)
- (MUL L ,source2 ,target))))))
-
-(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
- (lambda (target source n)
- (cond ((zero? n)
- (LAP (CLR L ,target)))
- ((eq? source target)
- (cond ((= n 1)
- (LAP))
- ((= n -1)
- (LAP (MNEG L ,target ,target)))
- ((integer-log-base-2? n)
- =>
- (lambda (power-of-2)
- (LAP (ASH L ,(make-immediate power-of-2)
- ,target ,target))))
- (else
- (LAP (MUL L ,(make-immediate n) ,target)))))
- ((= n 1)
- (MOV L ,source ,target))
- ((= n -1)
- (LAP (MNEG L ,source ,target)))
- ((integer-log-base-2? n)
- =>
- (lambda (power-of-2)
- (LAP (ASH L ,(make-immediate power-of-2) ,source ,target))))
- (else
- (LAP (MUL L ,(make-immediate n) ,source ,target))))))
-
-(define (integer-log-base-2? n)
- (let loop ((power 1) (exponent 0))
- (cond ((< n power) false)
- ((= n power) exponent)
- (else (loop (* 2 power) (1+ exponent))))))
-\f
-(define-fixnum-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (target source)
- (if (eq? source target)
- (LAP (ADD L (& #x100) ,target))
- (LAP (ADD L (& #x100) ,source ,target)))))
-
-(define-fixnum-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (target source)
- (if (eq? source target)
- (LAP (SUB L (& #x100) ,target))
- (LAP (SUB L (& #x100) ,source ,target)))))
-
-(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args
- (lambda (target source1 source2)
- (cond ((equal? source1 source2)
- (LAP (CLR L ,target)))
- ((eq? source1 target)
- (LAP (SUB L ,source2 ,target)))
- (else
- (LAP (SUB L ,source2 ,source1 ,target))))))
-
-(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
- (lambda (target source n)
- (cond ((eq? source target)
- (if (zero? n)
- (LAP)
- (LAP (SUB L (& ,(* n #x100)) ,target))))
- ((zero? n)
- (LAP (MOV L ,source ,target)))
- (else
- (LAP (SUB L (& ,(* n #x100)) ,source ,target))))))
-
-(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-tnatsnoc
- (lambda (target n source)
- (if (zero? n)
- (LAP (MNEG L ,source ,target))
- (LAP (SUB L ,source (& ,(* n #x100)) ,target)))))
-\f
-;;;; Operation utilities
-
-(define (fixnum-choose-target target operate-on-pseudo operate-on-target)
- (case (rtl:expression-type target)
- ((REGISTER)
- (let ((register (rtl:register-number target)))
- (if (pseudo-register? register)
- (operate-on-pseudo register)
- (operate-on-target (register-reference register)))))
- ((OFFSET)
- (operate-on-target (offset->indirect-reference! target)))
- (else
- (error "fixnum-choose-target: Unknown fixnum target" target))))
-
-(define (fixnum-1-arg target source operation)
- (fixnum-choose-target
- target
- (lambda (target)
- (let ((get-target (register-copy-if-available source 'GENERAL target)))
- (if get-target
- (let ((target (get-target)))
- (operation target target))
- (let* ((source (standard-fixnum-reference source))
- (target (standard-target-reference target)))
- (operation target source)))))
- (lambda (target)
- (operation target (standard-fixnum-reference source)))))
-
-(define (fixnum-2-args target source1 source2 operation)
- (fixnum-choose-target
- target
- (lambda (target)
- (let ((get-target (register-copy-if-available source1 'GENERAL target)))
- (if get-target
- (let* ((source2 (standard-fixnum-reference source2))
- (target (get-target)))
- (operation target target source2))
- (let ((get-target
- (register-copy-if-available source2 'GENERAL target)))
- (if get-target
- (let* ((source1 (standard-fixnum-reference source1))
- (target (get-target)))
- (operation target source1 target))
- (let ((source1 (standard-fixnum-reference source1))
- (source2 (standard-fixnum-reference source2)))
- (operation (standard-target-reference target)
- source1
- source2)))))))
- (lambda (target)
- (let* ((source1 (standard-fixnum-reference source1))
- (source2 (standard-fixnum-reference source2)))
- (operation target source1 source2)))))
+ (fixnum->object/temp r
+ (lambda (temp)
+ (LAP (PUSHL ,temp)))))
\f
-;;;; Operation rules
+;;;; Fixnum Operations
(define-rule statement
- (ASSIGN (? target) (FIXNUM-1-ARG (? operator) (REGISTER (? source))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (ASSIGN (? target)
+ (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
+ (QUALIFIER (machine-operation-target? target))
+ overflow? ; ignored
(fixnum-1-arg target source (fixnum-1-arg/operate operator)))
+(define-rule statement
+ (ASSIGN (? target)
+ (FIXNUM-2-ARGS (? operator)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ (QUALIFIER (machine-operation-target? target))
+ overflow? ; ignored
+ (fixnum-2-args target source1 source2 (fixnum-2-args/operate operator)))
+
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS (? operator)
(REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (? overflow?)))
+ (QUALIFIER (machine-operation-target? target))
+ overflow? ; ignored
(fixnum-2-args/register*constant operator target source constant))
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS (? operator)
(OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER (machine-operation-target? target))
+ overflow? ; ignored
(if (fixnum-2-args/commutative? operator)
(fixnum-2-args/register*constant operator target source constant)
(fixnum-2-args/constant*register operator target constant source)))
-(define (fixnum-2-args/register*constant operator target source constant)
- (fixnum-1-arg
- target source
- (lambda (target source)
- ((fixnum-2-args/operate-constant operator) target source constant))))
-
-(define (fixnum-2-args/constant*register operator target constant source)
- (fixnum-1-arg
- target source
- (lambda (target source)
- ((fixnum-2-args/operate-tnatsnoc operator) target constant source))))
-\f
-;;; This code is disabled on the MC68020 because of shifting problems.
-;; The constant 4 is treated especially because it appears in computed
-;; vector-{ref,set!} operations.
-
-(define (convert-index->fixnum/register target source)
- (fixnum-1-arg
- target source
- (lambda (target source)
- (LAP (ASH L (S 10) ,source ,target)))))
-
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(OBJECT->FIXNUM (CONSTANT 4))
- (OBJECT->FIXNUM (REGISTER (? source)))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ (? overflow?)))
+ (QUALIFIER (machine-operation-target? target))
+ overflow? ; ignored
(convert-index->fixnum/register target source))
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT 4))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (OBJECT->FIXNUM (CONSTANT 4))
+ (? overflow?)))
+ (QUALIFIER (machine-operation-target? target))
+ overflow? ; ignored
(convert-index->fixnum/register target source))
-
-(define (convert-index->fixnum/offset target address offset)
- (let ((source (indirect-reference! address offset)))
- (fixnum-choose-target
- target
- (lambda (pseudo)
- (LAP (ASH L (S 10) ,source ,(standard-target-reference pseudo))))
- (lambda (target)
- (LAP (ASH L (S 10) ,source ,target))))))
-
+\f
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(OBJECT->FIXNUM (CONSTANT 4))
- (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))))
- (QUALIFIER (fixnum-operation-target? target))
+ (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
+ (? overflow?)))
+ (QUALIFIER (machine-operation-target? target))
+ overflow? ; ignored
(convert-index->fixnum/offset target r n))
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
- (OBJECT->FIXNUM (CONSTANT 4))))
- (QUALIFIER (fixnum-operation-target? target))
+ (OBJECT->FIXNUM (CONSTANT 4))
+ (? overflow?)))
+ (QUALIFIER (machine-operation-target? target))
+ overflow? ; ignored
(convert-index->fixnum/offset target r n))
-\f
-;;;; General 2 operand rules
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS (? operator)
- (REGISTER (? source1))
- (REGISTER (? source2))))
- (QUALIFIER (and (fixnum-operation-target? target)
- (not (eq? operator 'MULTIPLY-FIXNUM))
- (pseudo-register? source1)
- (pseudo-register? source2)))
- (fixnum-2-args target source1 source2 (fixnum-2-args/operate operator)))
+#|
+;; These could be used for multiply instead of the generic rule used above.
+;; They are better when the target is in memory, but they are not worth it.
(define-rule statement
(ASSIGN (REGISTER (? target))
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(REGISTER (? source1))
(REGISTER (? source2))))
- (QUALIFIER (and (pseudo-register? source1)
- (pseudo-register? source2)))
(fixnum-2-args `(REGISTER ,target)
source1 source2
(fixnum-2-args/operate 'MULTIPLY-FIXNUM)))
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(REGISTER (? source1))
(REGISTER (? source2))))
- (QUALIFIER (and (pseudo-register? source1)
- (pseudo-register? source2)))
- (let ((target (indirect-reference! base offset)))
- (let ((get-temp (temporary-copy-if-available source1 'GENERAL)))
- (if get-temp
- (let ((source2 (standard-fixnum-reference source2))
- (temp (get-temp)))
- (LAP (ASH L (& -8) ,temp ,temp)
- (MUL L ,temp ,source2 ,target)))
- (let ((get-temp (temporary-copy-if-available source2 'GENERAL)))
- (if get-temp
- (let ((source1 (standard-fixnum-reference source1))
- (temp (get-temp)))
- (LAP (ASH L (& -8) ,temp ,temp)
- (MUL L ,source1 ,temp ,target)))
- (let ((source1 (standard-fixnum-reference source1))
- (source2 (standard-fixnum-reference source2))
- (temp (reference-temporary-register! 'GENERAL)))
- (LAP (ASH L (& -8) ,source1 ,temp)
- (MUL L ,temp ,source2 ,target)))))))))
+ (let* ((shift (- 0 scheme-type-width))
+ (target (indirect-reference! base offset))
+ (get-temp (temporary-copy-if-available source1 'GENERAL)))
+ (if get-temp
+ (let ((source2 (any-register-reference source2))
+ (temp (get-temp)))
+ (LAP (ASH L ,(make-immediate shift) ,temp ,temp)
+ (MUL L ,temp ,source2 ,target)))
+ (let ((get-temp (temporary-copy-if-available source2 'GENERAL)))
+ (if get-temp
+ (let ((source1 (any-register-reference source1))
+ (temp (get-temp)))
+ (LAP (ASH L ,(make-immediate shift) ,temp ,temp)
+ (MUL L ,source1 ,temp ,target)))
+ (let ((source1 (any-register-reference source1))
+ (source2 (any-register-reference source2))
+ (temp (reference-temporary-register! 'GENERAL)))
+ (LAP (ASH L ,(make-immediate shift) ,source1 ,temp)
+ (MUL L ,temp ,source2 ,target))))))))
+|#
\f
;;;; Fixnum Predicates
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
- (QUALIFIER (pseudo-register? register))
(set-standard-branches! (fixnum-predicate->cc predicate))
- (test-fixnum (standard-fixnum-reference register)))
+ (test-fixnum/ea (any-register-reference register)))
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (OBJECT->FIXNUM (REGISTER (? register))))
+ (set-standard-branches! (fixnum-predicate->cc predicate))
+ (let ((temporary (standard-temporary-reference)))
+ (object->fixnum (any-register-reference register) temporary)))
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (? memory))
(QUALIFIER (predicate/memory-operand? memory))
(set-standard-branches! (fixnum-predicate->cc predicate))
- (test-fixnum (predicate/memory-operand-reference memory)))
+ (test-fixnum/ea (predicate/memory-operand-reference memory)))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(REGISTER (? register-1))
(REGISTER (? register-2)))
- (QUALIFIER (and (pseudo-register? register-1)
- (pseudo-register? register-2)))
(compare/register*register register-1
register-2
(fixnum-predicate->cc predicate)))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate) (REGISTER (? register)) (? memory))
- (QUALIFIER (and (predicate/memory-operand? memory)
- (pseudo-register? register)))
+ (QUALIFIER (predicate/memory-operand? memory))
(compare/register*memory register
(predicate/memory-operand-reference memory)
(fixnum-predicate->cc predicate)))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate) (? memory) (REGISTER (? register)))
- (QUALIFIER (and (predicate/memory-operand? memory)
- (pseudo-register? register)))
+ (QUALIFIER (predicate/memory-operand? memory))
(compare/register*memory
register
(predicate/memory-operand-reference memory)
(compare/memory*memory (predicate/memory-operand-reference memory-1)
(predicate/memory-operand-reference memory-2)
(fixnum-predicate->cc predicate)))
-\f
-(define (fixnum-predicate/register*constant register constant cc)
- (set-standard-branches! cc)
- (guarantee-signed-fixnum constant)
- (if (zero? constant)
- (LAP ,(test-fixnum (standard-fixnum-reference register)))
- (LAP (CMP L ,(standard-fixnum-reference register)
- (& ,(* constant #x100))))))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(REGISTER (? register))
(OBJECT->FIXNUM (CONSTANT (? constant))))
- (QUALIFIER (pseudo-register? register))
(fixnum-predicate/register*constant register
constant
(fixnum-predicate->cc predicate)))
-
+\f
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(OBJECT->FIXNUM (CONSTANT (? constant)))
(REGISTER (? register)))
- (QUALIFIER (pseudo-register? register))
(fixnum-predicate/register*constant
register
constant
(invert-cc-noncommutative (fixnum-predicate->cc predicate))))
-(define (fixnum-predicate/memory*constant memory constant cc)
- (set-standard-branches! cc)
- (guarantee-signed-fixnum constant)
- (if (zero? constant)
- (LAP ,(test-fixnum memory))
- (LAP (CMP L ,memory (& ,(* constant #x100))))))
-
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(? memory)
(fixnum-predicate/memory*constant
(predicate/memory-operand-reference memory)
constant
- (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
\ No newline at end of file
+ (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
+
+;; This assumes that the last instruction sets the condition code bits
+;; correctly.
+
+(define-rule predicate
+ (OVERFLOW-TEST)
+ (set-standard-branches! 'VS)
+ (LAP))
+
+;;;; Utilities
+
+(define-integrable (datum->fixnum source target)
+ ;; This drops the type code
+ (LAP (ASH L (S ,scheme-type-width) ,source ,target)))
+
+(define-integrable (fixnum->datum source target)
+ ;; This maintains the type code, if any.
+ (LAP (ROTL (S ,scheme-datum-width) ,source ,target)))
+
+(define (object->fixnum source target)
+ (datum->fixnum source target))
+
+(define-integrable (ct/object->fixnum object target)
+ (load-fixnum-constant object target))
+
+(define (address->fixnum source target)
+ (datum->fixnum source target))
+
+(define-integrable (ct/address->fixnum address target)
+ (load-fixnum-constant (careful-object-datum address) target))
+
+(define (fixnum->object source target)
+ (LAP ,@(if (eq? target source)
+ (LAP (BIS L (S ,(ucode-type fixnum)) ,target))
+ (LAP (BIS L (S ,(ucode-type fixnum)) ,source ,target)))
+ ,@(fixnum->datum target target)))
+
+(define-integrable (ct/fixnum->object fixnum target)
+ (load-constant fixnum target))
+\f
+(define (fixnum->address source target)
+ (fixnum->datum source target))
+
+(define (ct/fixnum->address fixnum target)
+ (load-immediate fixnum target))
+
+(define (fixnum->object/temp source handler)
+ ;; We can't use fixnum->object to the heap or stack directly because
+ ;; fixnum->object expands into multiple instructions.
+ (let ((source (any-register-reference source))
+ (temp (standard-temporary-reference)))
+ (LAP ,@(fixnum->object source temp)
+ ,@(handler temp))))
+
+(define-integrable fixnum-1
+ ;; (expt 2 scheme-type-width) ***
+ 64)
+
+(define-integrable fixnum-bits-mask
+ (-1+ fixnum-1))
+
+(define (load-fixnum-constant constant target)
+ (cond ((zero? constant)
+ (LAP (CLR L ,target)))
+ ((<= 1 constant 63)
+ (LAP (ASH L (S ,scheme-type-width) (S ,constant) ,target)))
+ (else
+ (let* ((constant (* constant fixnum-1))
+ (size (datum-size constant)))
+ (cond ((not (eq? size 'L))
+ (LAP (CVT ,size L ,(make-immediate constant) ,target)))
+ ((and (positive? constant) (< constant #x10000))
+ (LAP (MOVZ W L ,(make-immediate constant) ,target)))
+ (else
+ (LAP (MOV L ,(make-immediate constant) ,target))))))))
+
+(define (machine-operation-target? target)
+ (or (rtl:register? target)
+ (and (rtl:offset? target)
+ (rtl:register? (rtl:offset-base target)))))
+
+(define (fixnum-choose-target target operate-on-pseudo operate-on-target)
+ (cond ((rtl:register? target)
+ (let ((register (rtl:register-number target)))
+ (if (pseudo-register? register)
+ (operate-on-pseudo register)
+ (operate-on-target (register-reference register)))))
+ ((rtl:offset? target)
+ (operate-on-target (offset->indirect-reference! target)))
+ (else
+ (error "fixnum-choose-target: Not a machine-operation-target"
+ target))))
+
+(define (convert-index->fixnum/register target source)
+ (fixnum-1-arg
+ target source
+ (lambda (target source)
+ (LAP (ASH L (S ,(+ scheme-type-width 2)) ,source ,target)))))
+
+(define (convert-index->fixnum/offset target address offset)
+ (let ((source (indirect-reference! address offset)))
+ (fixnum-choose-target
+ target
+ (lambda (pseudo)
+ (let ((target (standard-target-reference pseudo)))
+ (LAP (ASH L (S ,(+ scheme-type-width 2)) ,source ,target))))
+ (lambda (target)
+ (LAP (ASH L (S ,(+ scheme-type-width 2)) ,source ,target))))))
+\f
+;;;; Fixnum operation dispatch
+
+(define (define-fixnum-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-fixnum-method operator methods)
+ (cdr (or (assq operator (cdr methods))
+ (error "Unknown operator" operator))))
+
+(define fixnum-methods/1-arg
+ (list 'FIXNUM-METHODS/1-ARG))
+
+(define-integrable (fixnum-1-arg/operate operator)
+ (lookup-fixnum-method operator fixnum-methods/1-arg))
+
+(define fixnum-methods/2-args
+ (list 'FIXNUM-METHODS/2-ARGS))
+
+(define-integrable (fixnum-2-args/operate operator)
+ (lookup-fixnum-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-fixnum-method operator fixnum-methods/2-args-constant))
+
+(define fixnum-methods/2-args-tnatsnoc
+ (list 'FIXNUM-METHODS/2-ARGS-TNATSNOC))
+
+(define-integrable (fixnum-2-args/operate-tnatsnoc operator)
+ (lookup-fixnum-method operator fixnum-methods/2-args-tnatsnoc))
+
+(define (fixnum-2-args/commutative? operator)
+ (memq operator '(PLUS-FIXNUM
+ MULTIPLY-FIXNUM
+ FIXNUM-AND
+ FIXNUM-OR
+ FIXNUM-XOR)))
+
+(define (fixnum-1-arg target source operation)
+ (fixnum-choose-target
+ target
+ (lambda (target)
+ (cond ((register-copy-if-available source 'GENERAL target)
+ =>
+ (lambda (get-target)
+ (let ((target (get-target)))
+ (operation target target))))
+ (else
+ (let* ((source (any-register-reference source))
+ (target (standard-target-reference target)))
+ (operation target source)))))
+ (lambda (target)
+ (let ((source (any-register-reference source)))
+ (operation target source)))))
+
+(define-integrable (commute target source1 source2 recvr1 recvr2)
+ (cond ((ea/same? target source1)
+ (recvr1 source2))
+ ((ea/same? target source2)
+ (recvr1 source1))
+ (else
+ (recvr2))))
+\f
+(define (fixnum-2-args target source1 source2 operation)
+ (fixnum-choose-target
+ target
+ (lambda (target)
+ (cond ((register-copy-if-available source1 'GENERAL target)
+ =>
+ (lambda (get-target)
+ (let* ((source2 (any-register-reference source2))
+ (target (get-target)))
+ (operation target target source2))))
+ ((register-copy-if-available source2 'GENERAL target)
+ =>
+ (lambda (get-target)
+ (let* ((source1 (any-register-reference source1))
+ (target (get-target)))
+ (operation target source1 target))))
+ (else
+ (let* ((source1 (any-register-reference source1))
+ (source2 (any-register-reference source2))
+ (target (standard-target-reference target)))
+ (operation target source1 source2)))))
+ (lambda (target)
+ (let* ((source1 (any-register-reference source1))
+ (source2 (any-register-reference source2)))
+ (operation target source1 source2)))))
+
+(define (fixnum-2-args/register*constant operator target source constant)
+ (fixnum-1-arg
+ target source
+ (lambda (target source)
+ ((fixnum-2-args/operate-constant operator) target source constant))))
+
+(define (fixnum-2-args/constant*register operator target constant source)
+ (fixnum-1-arg
+ target source
+ (lambda (target source)
+ ((fixnum-2-args/operate-tnatsnoc operator) target constant source))))
+
+(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 (word->fixnum/ea source target)
+ (if (eq? target source)
+ (LAP (BIC B ,(make-immediate fixnum-bits-mask) ,target))
+ (LAP (BIC B ,(make-immediate fixnum-bits-mask) ,source ,target))))
+
+;; This is used instead of add-constant/ea because add-constant/ea is not
+;; guaranteed to set the overflow flag correctly.
+
+(define (add-fixnum-constant source constant target)
+ ;; This ignores instructions like INC and DEC because
+ ;; word is always too big.
+ (let ((word (* constant fixnum-1)))
+ (cond ((zero? word)
+ (ea/copy source target))
+ ((ea/same? source target)
+ (LAP (ADD L ,(make-immediate word) ,target)))
+ (else
+ (LAP (ADD L ,(make-immediate word) ,source ,target))))))
+
+(define-integrable (target-or-register target)
+ (if (effective-address/register? target)
+ target
+ (standard-temporary-reference)))
+\f
+;;;; Arithmetic operations
+
+(define-fixnum-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target source)
+ (add-fixnum-constant source 1 target)))
+
+(define-fixnum-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target source)
+ (add-fixnum-constant source -1 target)))
+
+(define-fixnum-method 'FIXNUM-NOT fixnum-methods/1-arg
+ (lambda (target source)
+ (let ((rtarget (target-or-register target)))
+ (LAP (MCOM L ,source ,rtarget)
+ ,@(word->fixnum/ea rtarget target)))))
+
+(let-syntax
+ ((binary/commutative
+ (macro (name instr eql)
+ `(define-fixnum-method ',name fixnum-methods/2-args
+ (lambda (target source1 source2)
+ (if (ea/same? source1 source2)
+ (,eql target
+ (if (or (eq? target source1)
+ (eq? target source2))
+ target
+ source1))
+ (commute target source1 source2
+ (lambda (source*)
+ (LAP (,instr L ,',source* ,',target)))
+ (lambda ()
+ (LAP (,instr L ,',source1 ,',source2
+ ,',target)))))))))
+
+ (binary/noncommutative
+ (macro (name instr)
+ `(define-fixnum-method ',name fixnum-methods/2-args
+ (lambda (target source1 source2)
+ (cond ((ea/same? source1 source2)
+ (load-fixnum-constant 0 target))
+ ((eq? target source1)
+ (LAP (,instr L ,',source2 ,',target)))
+ (else
+ (LAP (,instr L ,',source2 ,',source1 ,',target)))))))))
+
+ (binary/commutative PLUS-FIXNUM ADD
+ (lambda (target source)
+ (if (eq? target source)
+ (LAP (ADD L ,source ,target))
+ (LAP (ADD L ,source ,source ,target)))))
+
+ (binary/commutative FIXNUM-OR BIS
+ (lambda (target source)
+ (if (eq? target source)
+ (LAP)
+ (LAP (MOV L ,source ,target)))))
+
+ (binary/commutative FIXNUM-XOR XOR
+ (lambda (target source)
+ source ; ignored
+ (load-fixnum-constant target)))
+
+ (binary/noncommutative MINUS-FIXNUM SUB)
+
+ (binary/noncommutative FIXNUM-ANDC BIC))
+\f
+(define-fixnum-method 'FIXNUM-AND fixnum-methods/2-args
+ (lambda (target source1 source2)
+ (if (ea/same? source1 source2)
+ (ea/copy source1 target)
+ (let ((temp (standard-temporary-reference)))
+ (commute target source1 source2
+ (lambda (source*)
+ (LAP (MCOM L ,source* ,temp)
+ (BIC L ,temp ,target)))
+ (lambda ()
+ (LAP (MCOM L ,source1 ,temp)
+ (BIC L ,temp ,source2 ,target))))))))
+
+(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
+ (let ((shift (- 0 scheme-type-width)))
+ (lambda (target source1 source2)
+ (if (not (effective-address/register? target))
+ (let ((temp (standard-temporary-reference)))
+ (commute target source1 source2
+ (lambda (source*)
+ (LAP (ASH L ,(make-immediate shift) ,source* ,temp)
+ (MUL L ,temp ,target)))
+ (lambda ()
+ (LAP (ASH L ,(make-immediate shift) ,source1 ,temp)
+ (MUL L ,temp ,source2 ,target)))))
+ (commute
+ target source1 source2
+ (lambda (source*)
+ (cond ((not (ea/same? target source*))
+ (LAP (ASH L ,(make-immediate shift) ,target ,target)
+ (MUL L ,source* ,target)))
+ ((even? scheme-type-width)
+ (let ((shift (quotient shift 2)))
+ (LAP (ASH L ,(make-immediate shift) ,target ,target)
+ (MUL L ,target ,target))))
+ (else
+ (let ((temp (standard-temporary-reference)))
+ (LAP (ASH L ,(make-immediate shift) ,target ,temp)
+ (MUL L ,temp ,target))))))
+ (lambda ()
+ (LAP (ASH L ,(make-immediate shift) ,source1 ,target)
+ (MUL L ,source2 ,target))))))))
+
+(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args
+ (lambda (target source1 source2)
+ (let* ((rtarget (target-or-register target))
+ (temp (if (eq? rtarget target)
+ (standard-temporary-reference)
+ rtarget)))
+ (LAP (ASH L ,(make-immediate (- 0 scheme-type-width))
+ ,source2 ,temp)
+ (ASH L ,temp ,source1 ,rtarget)
+ ,@(word->fixnum/ea rtarget target)))))
+
+(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
+ (lambda (target source1 source2)
+ (if (ea/same? source1 source2)
+ (load-fixnum-constant 1 target)
+ (code-fixnum-quotient target source1 source2))))
+
+(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args
+ (lambda (target source1 source2)
+ (if (ea/same? source1 source2)
+ (load-fixnum-constant 0 target)
+ (code-fixnum-remainder target source1 source2))))
+\f
+(define-fixnum-method 'PLUS-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (add-fixnum-constant source n target)))
+
+(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (add-fixnum-constant source (- 0 n) target)))
+
+(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-tnatsnoc
+ (lambda (target n source)
+ (if (zero? n)
+ (LAP (MNEG L ,source ,target))
+ (LAP (SUB L ,source ,(make-immediate (* n fixnum-1)) ,target)))))
+
+(let-syntax
+ ((binary-fixnum/constant
+ (macro (name instr null ->constant identity?)
+ `(define-fixnum-method ',name fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (cond ((eqv? n ,null)
+ (load-fixnum-constant ,null target))
+ ((,identity? n)
+ (ea/copy source target))
+ (else
+ (let ((constant (* fixnum-1 (,->constant n))))
+ (if (ea/same? source target)
+ (LAP (,instr L ,',(make-immediate constant)
+ ,',target))
+ (LAP (,instr L ,',(make-immediate constant)
+ ,',source ,',target)))))))))))
+
+ (binary-fixnum/constant FIXNUM-OR BIS -1 identity-procedure zero?)
+
+ (binary-fixnum/constant FIXNUM-XOR XOR 'SELF identity-procedure zero?)
+
+ (binary-fixnum/constant FIXNUM-AND BIC 0 fix:not
+ (lambda (n)
+ (= n -1))))
+
+(define-fixnum-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (cond ((zero? n)
+ (ea/copy source target))
+ ((= n -1)
+ (load-fixnum-constant 0 target))
+ ((eq? target source)
+ (LAP (BIC L ,(make-immediate (* n fixnum-1)) ,target)))
+ (else
+ (LAP (BIC L ,(make-immediate (* n fixnum-1)) ,source ,target))))))
+
+(define-fixnum-method 'FIXNUM-ANDC fixnum-methods/2-args-tnatsnoc
+ (lambda (target n source)
+ (if (zero? n)
+ (load-fixnum-constant 0 target)
+ (LAP (BIC L ,source ,(make-immediate (* n fixnum-1)) ,target)))))
+
+(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (cond ((zero? n)
+ (ea/copy source target))
+ ((not (<= (- 0 scheme-datum-width) n scheme-datum-width))
+ (load-fixnum-constant 0 target))
+ ((negative? n)
+ (let ((rtarget (target-or-register target)))
+ (LAP (ASH L ,(make-immediate n) ,source ,rtarget)
+ ,@(word->fixnum/ea rtarget target))))
+ (else
+ (LAP (ASH L ,(make-immediate n) ,source ,target))))))
+\f
+(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args-tnatsnoc
+ (lambda (target n source)
+ (if (zero? n)
+ (load-fixnum-constant 0 target)
+ (let ((rtarget (target-or-register target)))
+ (LAP (ASH L ,(make-immediate (- 0 scheme-type-width)) ,source
+ ,rtarget)
+ (ASH L ,rtarget ,(make-immediate (* n fixnum-1)) ,rtarget)
+ ,@(word->fixnum/ea rtarget target))))))
+
+(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (cond ((zero? n)
+ (load-fixnum-constant 0 target))
+ ((= n 1)
+ (ea/copy source target))
+ ((= n -1)
+ (LAP (MNEG L ,source ,target)))
+ ((integer-power-of-2? (if (negative? n) (- 0 n) n))
+ =>
+ (lambda (expt-of-2)
+ (if (negative? n)
+ (let ((rtarget (target-or-register target)))
+ (LAP (ASH L ,(make-immediate expt-of-2) ,source ,rtarget)
+ (MNEG L ,rtarget ,target)))
+ (LAP (ASH L ,(make-immediate expt-of-2) ,source ,target)))))
+ ((eq? target source)
+ (LAP (MUL L ,(make-immediate n) ,target)))
+ (else
+ (LAP (MUL L ,(make-immediate n) ,source ,target))))))
+
+(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (cond ((= n 1)
+ (ea/copy source target))
+ ((= n -1)
+ (LAP (MNEG L ,source ,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))
+ (rtarget (target-or-register target)))
+ (LAP ,@(if (eq? rtarget source)
+ (LAP (TST L ,rtarget))
+ (LAP (MOV L ,source ,rtarget)))
+ (B GEQ (@PCR ,label))
+ (ADD L ,(make-immediate (* (-1+ absn) fixnum-1)) ,rtarget)
+ (LABEL ,label)
+ (ASH L ,(make-immediate (- 0 expt-of-2)) ,rtarget ,rtarget)
+ ,@(if (negative? n)
+ (LAP ,@(word->fixnum/ea rtarget rtarget)
+ (MNEG L ,rtarget ,target))
+ (word->fixnum/ea rtarget target))))))
+ (else
+ ;; This includes negative n.
+ (code-fixnum-quotient target source
+ (make-immediate (* n fixnum-1)))))))
+\f
+(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-tnatsnoc
+ (lambda (target n source)
+ (if (zero? n)
+ (load-fixnum-constant 0 target)
+ (code-fixnum-quotient target (make-immediate (* n fixnum-1))
+ source))))
+
+(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args-constant
+ (lambda (target source n)
+ ;; (remainder x y) is 0 or has the sign of x.
+ ;; Thus we can always "divide" by (abs y) to make things simpler.
+ (let ((n (if (negative? n) (- 0 n) n)))
+ (cond ((= n 1)
+ (load-fixnum-constant 0 target))
+ ((integer-power-of-2? n)
+ =>
+ (lambda (expt-of-2)
+ (let ((sign (standard-temporary-reference))
+ (label (generate-label 'REM-MERGE))
+ (nbits (+ scheme-type-width expt-of-2)))
+ ;; This may produce a branch to a branch, but a
+ ;; peephole optimizer should be able to fix this.
+ (LAP (EXTV S (S 31) (S 1) ,source ,sign)
+ (EXTV Z (S 0) (S ,nbits) ,source ,target)
+ (B EQL (@PCR ,label))
+ (INSV ,sign (S ,nbits) (S ,(- 32 nbits)) ,target)
+ (LABEL ,label)))))
+ (else
+ (code-fixnum-remainder target source
+ (make-immediate (* n fixnum-1))))))))
+
+(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args-tnatsnoc
+ (lambda (target n source)
+ (if (zero? n)
+ (load-fixnum-constant 0 target)
+ (code-fixnum-remainder target (make-immediate (* n fixnum-1))
+ source))))
+
+(define (code-fixnum-quotient target source1 source2)
+ (let ((rtarget (target-or-register target)))
+ (LAP ,@(if (eq? rtarget source1)
+ (LAP (DIV L ,source2 ,rtarget))
+ (LAP (DIV L ,source2 ,source1 ,rtarget)))
+ (ASH L (S ,scheme-type-width) ,rtarget ,target))))
+
+(define (code-fixnum-remainder target source1 source2)
+ #|
+ ;; This does not work because the second arg to EDIV
+ ;; is a quad and we have a long. It must be sign extended.
+ ;; In addition, the compiler does not currently support
+ ;; consecutive register allocation so the work must be done
+ ;; in memory.
+ (LAP (EDIV ,source2 ,source1 ,(standard-temporary-reference)
+ ,target))
+ |#
+ (define (perform source-reg temp)
+ ;; sign extend to quad on the stack
+ (LAP (EXTV S (S 31) (S 1) ,source-reg (@-R 14))
+ (PUSHL ,source-reg)
+ (EDIV ,source2 (@R+ 14) ,temp ,target)))
+
+ (let ((temp (standard-temporary-reference)))
+ (if (effective-address/register? source1)
+ (perform source1 temp)
+ (LAP (MOV L ,source1 ,temp)
+ ,@(perform temp temp)))))
+\f
+;;;; Predicate utilities
+
+(define (signed-fixnum? n)
+ (and (integer? n)
+ (>= n signed-fixnum/lower-limit)
+ (< n signed-fixnum/upper-limit)))
+
+(define (unsigned-fixnum? n)
+ (and (integer? n)
+ (not (negative? n))
+ (< n unsigned-fixnum/upper-limit)))
+
+(define (guarantee-signed-fixnum n)
+ (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
+ n)
+
+(define (guarantee-unsigned-fixnum n)
+ (if (not (unsigned-fixnum? n)) (error "Not a unsigned fixnum" n))
+ n)
+
+(define (fixnum-predicate->cc predicate)
+ (case predicate
+ ((EQUAL-FIXNUM? ZERO-FIXNUM?) 'EQL)
+ ((LESS-THAN-FIXNUM? NEGATIVE-FIXNUM?) 'LSS)
+ ((GREATER-THAN-FIXNUM? POSITIVE-FIXNUM?) 'GTR)
+ (else
+ (error "FIXNUM-PREDICATE->CC: Unknown predicate" predicate))))
+
+(define-integrable (test-fixnum/ea ea)
+ (LAP (TST L ,ea)))
+
+(define (fixnum-predicate/register*constant register constant cc)
+ (set-standard-branches! cc)
+ (guarantee-signed-fixnum constant)
+ (if (zero? constant)
+ (test-fixnum/ea (any-register-reference register))
+ (LAP (CMP L ,(any-register-reference register)
+ ,(make-immediate (* constant fixnum-1))))))
+
+(define (fixnum-predicate/memory*constant memory constant cc)
+ (set-standard-branches! cc)
+ (guarantee-signed-fixnum constant)
+ (if (zero? constant)
+ (test-fixnum/ea memory)
+ (LAP (CMP L ,memory ,(make-immediate (* constant fixnum-1))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff