From 414c25d4924f21fd0fd149415cf744f5327acf08 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Fri, 15 Feb 1991 00:42:38 +0000 Subject: [PATCH] Update for 7.1 port. --- v7/src/compiler/machines/vax/assmd.scm | 41 +- v7/src/compiler/machines/vax/compiler.cbf | 140 +-- v7/src/compiler/machines/vax/compiler.pkg | 104 +- v7/src/compiler/machines/vax/compiler.sf | 35 +- v7/src/compiler/machines/vax/dassm1.scm | 155 ++- v7/src/compiler/machines/vax/dassm2.scm | 103 +- v7/src/compiler/machines/vax/decls.scm | 112 +- v7/src/compiler/machines/vax/dsyn.scm | 20 +- v7/src/compiler/machines/vax/instr3.scm | 70 +- v7/src/compiler/machines/vax/insutl.scm | 43 +- v7/src/compiler/machines/vax/lapgen.scm | 723 +++++++------ v7/src/compiler/machines/vax/machin.scm | 318 +++--- v7/src/compiler/machines/vax/make.scm | 8 +- v7/src/compiler/machines/vax/rules1.scm | 482 +++++---- v7/src/compiler/machines/vax/rules2.scm | 171 ++- v7/src/compiler/machines/vax/rules3.scm | 550 ++++++---- v7/src/compiler/machines/vax/rules4.scm | 217 ++-- v7/src/compiler/machines/vax/rulfix.scm | 1176 +++++++++++++-------- 18 files changed, 2535 insertions(+), 1933 deletions(-) diff --git a/v7/src/compiler/machines/vax/assmd.scm b/v7/src/compiler/machines/vax/assmd.scm index bec42879d..b9e97d2b1 100644 --- a/v7/src/compiler/machines/vax/assmd.scm +++ b/v7/src/compiler/machines/vax/assmd.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -37,13 +37,7 @@ MIT in each case. |# (declare (usual-integrations)) -(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. @@ -52,44 +46,41 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/vax/compiler.cbf b/v7/src/compiler/machines/vax/compiler.cbf index 8168c6b9b..ab105064b 100644 --- a/v7/src/compiler/machines/vax/compiler.cbf +++ b/v7/src/compiler/machines/vax/compiler.cbf @@ -1,8 +1,8 @@ #| -*-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 @@ -32,128 +32,14 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Compiler Recompiling script - -((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 diff --git a/v7/src/compiler/machines/vax/compiler.pkg b/v7/src/compiler/machines/vax/compiler.pkg index 915212314..0cb526954 100644 --- a/v7/src/compiler/machines/vax/compiler.pkg +++ b/v7/src/compiler/machines/vax/compiler.pkg @@ -1,9 +1,9 @@ #| -*-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 @@ -71,6 +71,7 @@ MIT in each case. |# "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 ) @@ -79,20 +80,27 @@ MIT in each case. |# 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?)) (define-package (compiler reference-contexts) (files "base/refctx") @@ -161,20 +169,22 @@ MIT in each case. |# *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?*)) (define-package (compiler debug) (files "base/debug") (parent (compiler)) (export () - compiler:write-rtl-file debug/find-continuation debug/find-entry-node debug/find-procedure @@ -184,9 +194,12 @@ MIT in each case. |# 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") @@ -271,11 +284,8 @@ MIT in each case. |# 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) @@ -341,6 +351,11 @@ MIT in each case. |# (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)) @@ -354,7 +369,9 @@ MIT in each case. |# (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") @@ -381,7 +398,9 @@ MIT in each case. |# (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") @@ -420,6 +439,11 @@ MIT in each case. |# (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!)) (define-package (compiler rtl-generator) (files "rtlgen/rtlgen" ;RTL generator @@ -449,10 +473,6 @@ MIT in each case. |# (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) @@ -466,15 +486,21 @@ MIT in each case. |# (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") @@ -505,6 +531,24 @@ MIT in each case. |# (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)) @@ -512,7 +556,7 @@ MIT in each case. |# (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)) @@ -532,6 +576,7 @@ MIT in each case. |# "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 @@ -551,7 +596,12 @@ MIT in each case. |# 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)) @@ -565,10 +615,10 @@ MIT in each case. |# (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 @@ -596,7 +646,7 @@ MIT in each case. |# 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? diff --git a/v7/src/compiler/machines/vax/compiler.sf b/v7/src/compiler/machines/vax/compiler.sf index 1fdde8800..75fea6c48 100644 --- a/v7/src/compiler/machines/vax/compiler.sf +++ b/v7/src/compiler/machines/vax/compiler.sf @@ -1,9 +1,9 @@ #| -*-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 @@ -43,13 +43,13 @@ MIT in each case. |# (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. @@ -70,7 +70,15 @@ MIT in each case. |# ((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") @@ -88,20 +96,19 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/vax/dassm1.scm b/v7/src/compiler/machines/vax/dassm1.scm index 817ee5f6b..0b8a8cc7f 100644 --- a/v7/src/compiler/machines/vax/dassm1.scm +++ b/v7/src/compiler/machines/vax/dassm1.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -50,34 +50,46 @@ MIT in each case. |# (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) @@ -102,23 +114,10 @@ MIT in each case. |# (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 @@ -141,16 +140,9 @@ MIT in each case. |# (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)) @@ -195,34 +187,36 @@ MIT in each case. |# (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))) (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) @@ -233,24 +227,18 @@ MIT in each case. |# (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))) @@ -284,20 +272,19 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/vax/dassm2.scm b/v7/src/compiler/machines/vax/dassm2.scm index b9f3e6e7c..eaf411d6d 100644 --- a/v7/src/compiler/machines/vax/dassm2.scm +++ b/v7/src/compiler/machines/vax/dassm2.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -34,13 +34,14 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; VAX Disassembler: Top Level +;;; package: (compiler disassembler) (declare (usual-integrations)) - + (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) - + (set! disassembler/read-variable-cache (lambda (block index) (let-syntax ((ucode-type @@ -56,43 +57,14 @@ MIT in each case. |# (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 @# + ((#x9f17) ; JMP @& + ;; *** This should learn how to decode trampolines. *** (vector 'COMPILED - (read-procedure (+ offset 2)) + (read-procedure (+ offset 4)) arity)) - ((#x9f16) ; JSB @# - (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)))))))) @@ -202,7 +174,7 @@ MIT in each case. |# (let ((label (dbg-labels/find-offset symbol-table offset))) (and label (dbg-label/name label)))))) - + (define (external-label-marker? symbol-table offset state) (if symbol-table (let ((label (dbg-labels/find-offset symbol-table (+ offset 4)))) @@ -220,7 +192,7 @@ MIT in each case. |# (loop offset))) (= offset (/ (bit-string->unsigned-integer contents) 2)))))))) - + (define (make-data-deposit *ir size) (case size ((B) @@ -367,13 +339,50 @@ MIT in each case. |# ;; 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. diff --git a/v7/src/compiler/machines/vax/decls.scm b/v7/src/compiler/machines/vax/decls.scm index d179ed270..0121d79d4 100644 --- a/v7/src/compiler/machines/vax/decls.scm +++ b/v7/src/compiler/machines/vax/decls.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -33,7 +33,8 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Compiler File Dependencies. VAX compiler. +;;;; Compiler File Dependencies. VAX version. +;;; package: (compiler declarations) (declare (usual-integrations)) @@ -332,34 +333,36 @@ MIT in each case. |# 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" @@ -377,7 +380,17 @@ MIT in each case. |# ;;;; 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" @@ -387,23 +400,26 @@ MIT in each case. |# (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 @@ -456,7 +472,6 @@ MIT in each case. |# (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") @@ -465,8 +480,8 @@ MIT in each case. |# (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") @@ -490,7 +505,8 @@ MIT in each case. |# (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") @@ -502,25 +518,33 @@ MIT in each case. |# (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) @@ -531,7 +555,7 @@ MIT in each case. |# (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") diff --git a/v7/src/compiler/machines/vax/dsyn.scm b/v7/src/compiler/machines/vax/dsyn.scm index 2dd04dcde..2d47874a8 100644 --- a/v7/src/compiler/machines/vax/dsyn.scm +++ b/v7/src/compiler/machines/vax/dsyn.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -51,17 +51,17 @@ MIT in each case. |# (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)) diff --git a/v7/src/compiler/machines/vax/instr3.scm b/v7/src/compiler/machines/vax/instr3.scm index a27ddeea2..63ed7d680 100644 --- a/v7/src/compiler/machines/vax/instr3.scm +++ b/v7/src/compiler/machines/vax/instr3.scm @@ -1,9 +1,8 @@ #| -*-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 @@ -254,14 +253,16 @@ MIT in each case. |# ((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) @@ -288,25 +289,21 @@ MIT in each case. |# (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))))) @@ -316,23 +313,36 @@ MIT in each case. |# (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)))))) (let-syntax @@ -363,7 +373,21 @@ MIT in each case. |# ((-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))) diff --git a/v7/src/compiler/machines/vax/insutl.scm b/v7/src/compiler/machines/vax/insutl.scm index c61336c24..653db073d 100644 --- a/v7/src/compiler/machines/vax/insutl.scm +++ b/v7/src/compiler/machines/vax/insutl.scm @@ -1,9 +1,8 @@ #| -*-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 @@ -34,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; VAX utility procedures +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -141,6 +141,12 @@ MIT in each case. |# (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) @@ -151,9 +157,9 @@ MIT in each case. |# (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)) @@ -202,6 +208,8 @@ MIT in each case. |# (BYTE (32 off SIGNED))) ;; 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) @@ -211,7 +219,6 @@ MIT in each case. |# (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)) @@ -229,7 +236,6 @@ MIT in each case. |# (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)) @@ -237,7 +243,24 @@ MIT in each case. |# ((() ()) ; (@@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)))))) ;;;; Effective address processing @@ -261,7 +284,7 @@ MIT in each case. |# ((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)))))) @@ -321,4 +344,4 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/vax/lapgen.scm b/v7/src/compiler/machines/vax/lapgen.scm index 3428bb016..d7ec267b6 100644 --- a/v7/src/compiler/machines/vax/lapgen.scm +++ b/v7/src/compiler/machines/vax/lapgen.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -33,11 +33,13 @@ Technology nor of any adaptation thereof in any advertising, 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)) -;;;; Basic machine instructions +;;;; Register-Allocator Interface (define (reference->register-transfer source target) (if (and (effective-address/register? source) @@ -46,13 +48,64 @@ MIT in each case. |# (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))) + +;;;; Basic Machine Instructions (define-integrable (pseudo->machine-register source target) (memory->machine-register (pseudo-register-home source) target)) @@ -60,176 +113,325 @@ MIT in each case. |# (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))) + +;;;; 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))) -;; 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)))))) + +;;;; 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)))) + +;;;; 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)) +;;;; 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)))) +;;;; 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 @@ -259,9 +461,8 @@ MIT in each case. |# (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))) + +;;;; Utilities needed by the rules files (contd.) (define-integrable (effective-address/register? ea) (eq? (lap:ea-keyword ea) 'R)) @@ -271,22 +472,9 @@ MIT in each case. |# (define-integrable (effective-address/register-offset? ea) (eq? (lap:ea-keyword ea) '@RO)) - -(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) @@ -296,123 +484,26 @@ MIT in each case. |# (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))))))) -;;;; 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 - -;;;; 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) @@ -433,11 +524,6 @@ MIT in each case. |# ascii (- ascii 256)))) -(define (indirect-register register) - (if (machine-register? register) - register - (register-alias register false))) - (define-integrable (lap:ea-keyword expression) (car expression)) @@ -452,17 +538,37 @@ MIT in each case. |# (define-integrable (lap:ea-@RO-offset expression) (cadddr expression)) + +;;;; 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) @@ -472,70 +578,31 @@ MIT in each case. |# (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))) - -;;;; 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)))) - -;;;; 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 diff --git a/v7/src/compiler/machines/vax/machin.scm b/v7/src/compiler/machines/vax/machin.scm index 2084fa00b..d72aa70ea 100644 --- a/v7/src/compiler/machines/vax/machin.scm +++ b/v7/src/compiler/machines/vax/machin.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -34,80 +34,93 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Machine Model for DEC Vax +;;; package: (compiler) (declare (usual-integrations)) -;;; 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)) - -(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) @@ -119,100 +132,169 @@ MIT in each case. |# (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)))) -;; 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))) + +(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 diff --git a/v7/src/compiler/machines/vax/make.scm b/v7/src/compiler/machines/vax/make.scm index 527f1eef0..2deb34c90 100644 --- a/v7/src/compiler/machines/vax/make.scm +++ b/v7/src/compiler/machines/vax/make.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -43,4 +43,4 @@ MIT in each case. |# '((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 diff --git a/v7/src/compiler/machines/vax/rules1.scm b/v7/src/compiler/machines/vax/rules1.scm index 1a6dc9804..c8ef6d628 100644 --- a/v7/src/compiler/machines/vax/rules1.scm +++ b/v7/src/compiler/machines/vax/rules1.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -33,279 +33,269 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; LAP Generation Rules: Data Transfers. 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)) -;;;; 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)) + +(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)))) - -;;; 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)) + +;;;; 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)) - -(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)) + +;;;; 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)) - (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)))) - ;;;; 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)))) - + (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)))))) ;;;; 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))) @@ -315,55 +305,65 @@ MIT in each case. |# ;; 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)))) - + ;;;; 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)))) ;;;; 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)) @@ -371,23 +371,21 @@ MIT in each case. |# (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)) @@ -396,7 +394,7 @@ MIT in each case. |# (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 @@ -417,4 +415,74 @@ MIT in each case. |# (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))))) + +;;;; 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 diff --git a/v7/src/compiler/machines/vax/rules2.scm b/v7/src/compiler/machines/vax/rules2.scm index b3a1057d7..66955a565 100644 --- a/v7/src/compiler/machines/vax/rules2.scm +++ b/v7/src/compiler/machines/vax/rules2.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -33,96 +33,40 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; LAP Generation Rules: Predicates. 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)) -(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)))) - -(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)) @@ -134,47 +78,80 @@ MIT in each case. |# (compare/memory*memory (predicate/memory-operand-reference memory-1) (predicate/memory-operand-reference memory-2) 'EQL)) - -(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)) + +;;;; 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 diff --git a/v7/src/compiler/machines/vax/rules3.scm b/v7/src/compiler/machines/vax/rules3.scm index f36e5437c..b85c9aece 100644 --- a/v7/src/compiler/machines/vax/rules3.scm +++ b/v7/src/compiler/machines/vax/rules3.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -33,24 +33,34 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; LAP Generation Rules: Invocations and Entries. DEC VAX version. +;;;; LAP Generation Rules: Invocations and Entries. +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) ;;;; 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)) @@ -63,25 +73,25 @@ MIT in each case. |# 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)) @@ -92,51 +102,72 @@ MIT in each case. |# ;; The other possibility would be ;; (JMP (@@PCR ,(free-uuo-link-label name frame-size))) ;; and to have 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)))) + +;;; 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)))) (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 @@ -149,9 +180,14 @@ MIT in each case. |# 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 &*) @@ -172,8 +208,8 @@ MIT in each case. |# (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) @@ -182,20 +218,20 @@ MIT in each case. |# (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)))))) @@ -208,35 +244,35 @@ MIT in each case. |# (generate/move-frame-up frame-size (indirect-reference! base offset))) (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))))))) @@ -251,13 +287,13 @@ MIT in each case. |# (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))))) @@ -273,9 +309,7 @@ MIT in each case. |# ,@(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))))) @@ -283,14 +317,16 @@ MIT in each case. |# ;;;; 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)) @@ -309,41 +345,70 @@ MIT in each case. |# (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)) ;;;; 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))))) @@ -357,26 +422,33 @@ MIT in each case. |# (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)) @@ -385,129 +457,223 @@ MIT in each case. |# ,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))) ;;;; 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 (@& )) (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)))) + +(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 (@& )) + (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))))) ;;;; 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)))) + +(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)))) ;;; Local Variables: *** ;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** diff --git a/v7/src/compiler/machines/vax/rules4.scm b/v7/src/compiler/machines/vax/rules4.scm index 34c3ee097..eac509f7e 100644 --- a/v7/src/compiler/machines/vax/rules4.scm +++ b/v7/src/compiler/machines/vax/rules4.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -33,156 +33,113 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; LAP Generation Rules: Interpreter Calls. DEC VAX version. +;;;; LAP Generation Rules: Interpreter Calls. +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) -;;;; 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)))) -(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)))) - -(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 diff --git a/v7/src/compiler/machines/vax/rulfix.scm b/v7/src/compiler/machines/vax/rulfix.scm index e27801da6..36d070275 100644 --- a/v7/src/compiler/machines/vax/rulfix.scm +++ b/v7/src/compiler/machines/vax/rulfix.scm @@ -1,9 +1,9 @@ #| -*-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 @@ -33,485 +33,166 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; LAP Generation Rules: Fixnum operations. 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)) -;;;; 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))) - -;;;; 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))) - -;;;; 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)) - -(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)))) - -;;;; 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)))))) - -(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))))) - -;;;; 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))))) -;;;; 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)))) - -;;; 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)))))) - + (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)) - -;;;; 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))) @@ -521,63 +202,64 @@ MIT in each case. |# (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)))))))) +|# ;;;; 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) @@ -590,41 +272,24 @@ MIT in each case. |# (compare/memory*memory (predicate/memory-operand-reference memory-1) (predicate/memory-operand-reference memory-2) (fixnum-predicate->cc predicate))) - -(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))) - + (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) @@ -642,4 +307,623 @@ MIT in each case. |# (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)) + +(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)))))) + +;;;; 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)))) + +(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))) + +;;;; 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)) + +(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)))) + +(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)))))) + +(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))))))) + +(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))))) + +;;;; 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 -- 2.25.1