From: Guillermo J. Rozas Date: Wed, 17 May 1989 20:32:50 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~12069 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cf487b756c36aa300691e2b669fb8243d0b2b13c;p=mit-scheme.git Initial revision --- diff --git a/v7/src/compiler/machines/vax/compiler.cbf b/v7/src/compiler/machines/vax/compiler.cbf new file mode 100644 index 000000000..c8cb18667 --- /dev/null +++ b/v7/src/compiler/machines/vax/compiler.cbf @@ -0,0 +1,159 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/compiler.cbf,v 1.1 1989/05/17 20:32:18 jinx Exp $ + +Copyright (c) 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Recompiling script + +(compile-bin-file '( + "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/crsend" + "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 diff --git a/v7/src/compiler/machines/vax/compiler.pkg b/v7/src/compiler/machines/vax/compiler.pkg new file mode 100644 index 000000000..346f22017 --- /dev/null +++ b/v7/src/compiler/machines/vax/compiler.pkg @@ -0,0 +1,613 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/compiler.pkg,v 1.1 1989/05/17 20:32:35 jinx Exp $ +$MC68020-Header: comp.pkg,v 1.22 89/04/26 05:11:52 GMT cph Exp $ + +Copyright (c) 1988, 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Packaging + +(global-definitions "/scheme/runtime/runtim") + +(define-package (compiler) + (files "base/switch" + "base/hashtb" + "base/object" ;tagged object support + "base/enumer" ;enumerations + "base/sets" ;set abstraction + "base/mvalue" ;multiple-value support + "base/scode" ;SCode abstraction + "machines/vax/machin" ;machine dependent stuff + "base/utils" ;odds and ends + + "base/cfg1" ;control flow graph + "base/cfg2" + "base/cfg3" + + "base/ctypes" ;CFG datatypes + + "base/rvalue" ;Right hand values + "base/lvalue" ;Left hand values + "base/blocks" ;rvalue: blocks + "base/proced" ;rvalue: procedures + "base/contin" ;rvalue: continuations + + "base/subprb" ;subproblem datatype + + "rtlbase/rgraph" ;program graph abstraction + "rtlbase/rtlty1" ;RTL: type definitions + "rtlbase/rtlty2" ;RTL: type definitions + "rtlbase/rtlexp" ;RTL: expression operations + "rtlbase/rtlcon" ;RTL: complex constructors + "rtlbase/rtlreg" ;RTL: registers + "rtlbase/rtlcfg" ;RTL: CFG types + "rtlbase/rtlobj" ;RTL: CFG objects + "rtlbase/regset" ;RTL: register sets + + "back/insseq" ;LAP instruction sequences + ) + (parent ()) + (export () + compiler:analyze-side-effects? + compiler:cache-free-variables? + compiler:code-compression? + compiler:cse? + compiler:default-top-level-declarations + compiler:enable-expansion-declarations? + compiler:enable-integration-declarations? + compiler:generate-range-checks? + compiler:generate-rtl-files? + compiler:generate-type-checks? + compiler:implicit-self-static? + compiler:open-code-flonum-checks? + compiler:open-code-primitives? + compiler:optimize-environments? + compiler:package-optimization-level + compiler:preserve-data-structures? + compiler:show-subphases?)) + +(define-package (compiler reference-contexts) + (files "base/refctx") + (parent (compiler)) + (export (compiler) + add-reference-context/adjacent-parents! + initialize-reference-contexts! + make-reference-context + modify-reference-contexts! + reference-context/adjacent-parent? + reference-context/block + reference-context/offset + reference-context/procedure + reference-context? + set-reference-context/offset!)) + +(define-package (compiler balanced-binary-tree) + (files "base/btree") + (parent (compiler)) + (export (compiler) + btree-delete! + btree-fringe + btree-insert! + btree-lookup + make-btree)) + +(define-package (compiler macros) + (files "base/macros") + (parent ()) + (export (compiler) + assembler-syntax-table + compiler-syntax-table + early-syntax-table + lap-generator-syntax-table) + (import (runtime macros) + parse-define-syntax) + (initialization (initialize-package!))) + +(define-package (compiler declarations) + (files "machines/vax/decls") + (parent (compiler)) + (export (compiler) + sc + syntax-files!) + (import (scode-optimizer top-level) + sf/internal + sf/pathname-defaulting) + (initialization (initialize-package!))) + +(define-package (compiler top-level) + (files "base/toplev" + "base/crstop") + (parent (compiler)) + (export () + cf + compile-bin-file + compile-procedure + compiler:reset! + cross-compile-bin-file + cross-compile-bin-file-end) + (export (compiler fg-generator) + compile-recursively) + (export (compiler rtl-generator) + *ic-procedure-headers* + *rtl-continuations* + *rtl-expression* + *rtl-graphs* + *rtl-procedures*) + (export (compiler lap-syntaxer) + compiler:external-labels + label->object) + (export (compiler debug) + *root-expression* + *rtl-procedures* + *rtl-graphs*) + (import (runtime compiler-info) + make-dbg-info-vector)) + +(define-package (compiler debug) + (files "base/debug") + (parent (compiler)) + (export () + compiler:write-rtl-file + debug/find-continuation + debug/find-entry-node + debug/find-procedure + debug/where + dump-rtl + po + show-bblock-rtl + show-fg + show-fg-node + show-rtl) + (import (runtime pretty-printer) + *pp-primitives-by-name*)) + +(define-package (compiler pattern-matcher/lookup) + (files "base/pmlook") + (parent (compiler)) + (export (compiler) + make-pattern-variable + pattern-lookup + pattern-variable-name + pattern-variable? + pattern-variables)) + +(define-package (compiler pattern-matcher/parser) + (files "base/pmpars") + (parent (compiler)) + (export (compiler) + parse-rule + rule-result-expression) + (export (compiler macros) + parse-rule + rule-result-expression)) + +(define-package (compiler pattern-matcher/early) + (files "base/pmerly") + (parent (compiler)) + (export (compiler) + early-parse-rule + early-pattern-lookup + early-make-rule + make-database-transformer + make-symbol-transformer + make-bit-mask-transformer)) + +(define-package (compiler debugging-information) + (files "base/infnew") + (parent (compiler)) + (export (compiler top-level) + info-generation-phase-1 + info-generation-phase-2 + info-generation-phase-3) + (export (compiler rtl-generator) + generated-dbg-continuation) + (import (runtime compiler-info) + make-dbg-info + + make-dbg-expression + dbg-expression/block + dbg-expression/label + set-dbg-expression/label! + + make-dbg-procedure + dbg-procedure/block + dbg-procedure/label + set-dbg-procedure/label! + dbg-procedure/name + dbg-procedure/required + dbg-procedure/optional + dbg-procedure/rest + dbg-procedure/auxiliary + dbg-procedure/external-label + set-dbg-procedure/external-label! + dbg-procedureflow-graph converter + "fggen/declar" ;Declaration handling + ) + (parent (compiler)) + (export (compiler top-level) + canonicalize/top-level + construct-graph) + (import (runtime scode-data) + &pair-car + &pair-cdr + &triple-first + &triple-second + &triple-third)) + +(define-package (compiler fg-optimizer) + (files "fgopt/outer" ;outer analysis + "fgopt/sideff" ;side effect analysis + ) + (parent (compiler)) + (export (compiler top-level) + clear-call-graph! + compute-call-graph! + outer-analysis + side-effect-analysis)) + +(define-package (compiler fg-optimizer fold-constants) + (files "fgopt/folcon") + (parent (compiler fg-optimizer)) + (export (compiler top-level) fold-constants)) + +(define-package (compiler fg-optimizer operator-analysis) + (files "fgopt/operan") + (parent (compiler fg-optimizer)) + (export (compiler top-level) operator-analysis)) + +(define-package (compiler fg-optimizer environment-optimization) + (files "fgopt/envopt") + (parent (compiler fg-optimizer)) + (export (compiler top-level) optimize-environments!)) + +(define-package (compiler fg-optimizer closure-analysis) + (files "fgopt/closan") + (parent (compiler fg-optimizer)) + (export (compiler top-level) identify-closure-limits!)) + +(define-package (compiler fg-optimizer continuation-analysis) + (files "fgopt/contan") + (parent (compiler fg-optimizer)) + (export (compiler top-level) continuation-analysis)) + +(define-package (compiler fg-optimizer compute-node-offsets) + (files "fgopt/offset") + (parent (compiler fg-optimizer)) + (export (compiler top-level) compute-node-offsets)) + +(define-package (compiler fg-optimizer connectivity-analysis) + (files "fgopt/conect") + (parent (compiler fg-optimizer)) + (export (compiler top-level) connectivity-analysis)) + +(define-package (compiler fg-optimizer delete-integrated-parameters) + (files "fgopt/delint") + (parent (compiler fg-optimizer)) + (export (compiler top-level) delete-integrated-parameters)) + +(define-package (compiler fg-optimizer design-environment-frames) + (files "fgopt/desenv") + (parent (compiler fg-optimizer)) + (export (compiler top-level) design-environment-frames!)) + +(define-package (compiler fg-optimizer setup-block-types) + (files "fgopt/blktyp") + (parent (compiler fg-optimizer)) + (export (compiler top-level) + setup-block-types! + setup-closure-contexts!)) + +(define-package (compiler fg-optimizer simplicity-analysis) + (files "fgopt/simple") + (parent (compiler fg-optimizer)) + (export (compiler top-level) simplicity-analysis) + (export (compiler fg-optimizer subproblem-ordering) + new-subproblem/compute-simplicity!)) + +(define-package (compiler fg-optimizer simulate-application) + (files "fgopt/simapp") + (parent (compiler fg-optimizer)) + (export (compiler top-level) simulate-application)) + +(define-package (compiler fg-optimizer subproblem-free-variables) + (files "fgopt/subfre") + (parent (compiler fg-optimizer)) + (export (compiler top-level) compute-subproblem-free-variables) + (export (compiler fg-optimizer) map-union) + (export (compiler fg-optimizer subproblem-ordering) + new-subproblem/compute-free-variables!)) + +(define-package (compiler fg-optimizer subproblem-ordering) + (files "fgopt/order") + (parent (compiler fg-optimizer)) + (export (compiler top-level) subproblem-ordering)) + +(define-package (compiler fg-optimizer subproblem-ordering reuse-frames) + (files "fgopt/reord" "fgopt/reuse") + (parent (compiler fg-optimizer subproblem-ordering)) + (export (compiler top-level) setup-frame-adjustments) + (export (compiler fg-optimizer subproblem-ordering) + order-subproblems/maybe-overwrite-block)) + +(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis) + (files "fgopt/param") + (parent (compiler fg-optimizer subproblem-ordering)) + (export (compiler fg-optimizer subproblem-ordering) + parameter-analysis)) + +(define-package (compiler rtl-generator) + (files "rtlgen/rtlgen" ;RTL generator + "rtlgen/rgstmt" ;statements + "rtlgen/fndvar" ;find variables + "machines/vax/rgspcm" ;special close-coded primitives + "rtlbase/rtline" ;linearizer + ) + (parent (compiler)) + (export (compiler) + make-linearizer) + (export (compiler top-level) + generate/top-level + linearize-rtl + setup-bblock-continuations!) + (export (compiler debug) + linearize-rtl) + (import (compiler top-level) + label->object)) + +(define-package (compiler rtl-generator generate/procedure-header) + (files "rtlgen/rgproc") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) generate/procedure-header)) + +(define-package (compiler rtl-generator combination/inline) + (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) + (files "rtlgen/fndblk") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) find-block)) + +(define-package (compiler rtl-generator generate/rvalue) + (files "rtlgen/rgrval") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) + generate/rvalue + load-closure-environment + make-ic-cons + make-non-trivial-closure-cons + make-trivial-closure-cons)) + +(define-package (compiler rtl-generator generate/combination) + (files "rtlgen/rgcomb") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) + generate/combination)) + +(define-package (compiler rtl-generator generate/return) + (files "rtlgen/rgretn") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) + make-return-operand + generate/return + generate/return* + generate/trivial-return)) + +(define-package (compiler rtl-cse) + (files "rtlopt/rcse1" ;RTL common subexpression eliminator + "rtlopt/rcse2" + "rtlopt/rcseep" ;CSE expression predicates + "rtlopt/rcseht" ;CSE hash table + "rtlopt/rcserq" ;CSE register/quantity abstractions + "rtlopt/rcsesr" ;CSE stack references + ) + (parent (compiler)) + (export (compiler top-level) common-subexpression-elimination)) + +(define-package (compiler rtl-optimizer) + (files "rtlopt/rdebug") + (parent (compiler))) + +(define-package (compiler rtl-optimizer invertible-expression-elimination) + (files "rtlopt/rinvex") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) invertible-expression-elimination)) + +(define-package (compiler rtl-optimizer lifetime-analysis) + (files "rtlopt/rlife") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) lifetime-analysis) + (export (compiler rtl-optimizer code-compression) mark-set-registers!)) + +(define-package (compiler rtl-optimizer code-compression) + (files "rtlopt/rdeath") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) code-compression)) + +(define-package (compiler rtl-optimizer register-allocation) + (files "rtlopt/ralloc") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) register-allocation)) + +(define-package (compiler lap-syntaxer) + (files "back/lapgn1" ;LAP generator + "back/lapgn2" ; " " + "back/lapgn3" ; " " + "back/regmap" ;Hardware register allocator + "machines/vax/lapgen" ;code generation rules + "machines/vax/rules1" ; " " " + "machines/vax/rules2" ; " " " + "machines/vax/rules3" ; " " " + "machines/vax/rules4" ; " " " + "machines/vax/rulfix" ;code generation rules: fixnums + "back/syntax" ;Generic syntax phase + "back/syerly" ;Early binding version + "machines/vax/coerce" ;Coercions: integer -> bit string + "back/asmmac" ;Macros for hairy syntax + "machines/vax/insmac" ;Macros for hairy syntax + "machines/vax/inerly" ;Early binding version + "machines/vax/insutl" ;Utilities for instructions + "machines/vax/instr1" ;Vax Instructions + "machines/vax/instr2" ; " " + "machines/vax/instr3" ; " " + ) + (parent (compiler)) + (export (compiler) + lap-generator/match-rtl-instruction + lap:make-entry-point + lap:make-label-statement + lap:make-unconditional-branch + lap:syntax-instruction) + (export (compiler top-level) + generate-bits) + (import (scode-optimizer expansion) + scode->scode-expander)) + +(define-package (compiler lap-syntaxer map-merger) + (files "back/mermap") + (parent (compiler lap-syntaxer)) + (export (compiler lap-syntaxer) + merge-register-maps)) + +(define-package (compiler lap-syntaxer linearizer) + (files "back/linear") + (parent (compiler lap-syntaxer)) + (export (compiler lap-syntaxer) + linearize-bits + bblock-linearize-bits) + (export (compiler top-level) + linearize-bits)) + +(define-package (compiler assembler) + (files "machines/vax/assmd" ;Machine dependent + "back/symtab" ;Symbol tables + "back/bitutl" ;Assembly blocks + "back/bittop" ;Assembler top level + ) + (parent (compiler)) + (export (compiler) + instruction-append) + (export (compiler top-level) + assemble)) + +(define-package (compiler disassembler) + (files "machines/vax/dassm1" + "machines/vax/dassm2" + "machines/vax/dassm3" + "machines/vax/dinstr1" + "machines/vax/dinstr2" + "machines/vax/dinstr3" + ) + (parent (compiler)) + (export () + compiler:write-lap-file + compiler:disassemble) + (import (runtime compiler-info) + compiled-code-block/dbg-info + dbg-info-vector/items + dbg-info-vector? + dbg-info/labels + dbg-label/external? + dbg-label/name + dbg-labels/find-offset)) + +(define-package (compiler disassembler macros) + (files "machines/vax/dsyn" + ) + (parent (compiler disassembler)) + (export (compiler) + disassembler-syntax-table) + (initialization (initialize-package!))) \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/compiler.sf b/v7/src/compiler/machines/vax/compiler.sf new file mode 100644 index 000000000..5968836ea --- /dev/null +++ b/v7/src/compiler/machines/vax/compiler.sf @@ -0,0 +1,129 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/compiler.sf,v 1.1 1989/05/17 20:32:50 jinx Exp $ +$MC68020-Header: comp.sf,v 1.7 88/12/15 17:02:14 GMT cph Exp $ + +Copyright (c) 1988, 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Script to incrementally syntax the compiler + +;; Guarantee that the package modeller is loaded. +(if (not (name->package '(CROSS-REFERENCE))) + (with-working-directory-pathname "/scheme/cref" (lambda () (load "make")))) + +;; Guarantee that the compiler's package structure exists. +(if (not (name->package '(COMPILER))) + (begin + ;; If there is no existing package constructor, generate one. + (if (not (file-exists? "machines/vax/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"))) + +;; Guarantee that the necessary syntactic transforms and optimizers +;; are loaded. +(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!) + (let ((sf-and-load + (lambda (files package) + (sf-conditionally files) + (for-each (lambda (file) + (load (string-append file ".bin") package)) + files)))) + (write-string "\n\n---- Loading compile-time files ----") + (sf-and-load '("base/switch" "base/hashtb") '(COMPILER)) + (sf-and-load '("base/macros") '(COMPILER MACROS)) + ((access initialize-package! (->environment '(COMPILER MACROS)))) + (sf-and-load '("machines/vax/decls") '(COMPILER DECLARATIONS)) + (let ((environment (->environment '(COMPILER DECLARATIONS)))) + (set! (access source-file-expression environment) "*.scm") + ((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)) + (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER)) + (sf-and-load '("machines/vax/coerce" "back/asmmac" + "machines/vax/insmac") + '(COMPILER LAP-SYNTAXER)) + (sf-and-load '("base/scode") '(COMPILER)) + (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY)) + (sf-and-load '("machines/vax/inerly" "back/syerly") + '(COMPILER LAP-SYNTAXER)) + (sf-and-load '("machines/vax/dsyn") + '(COMPILER DISASSEMBLER MACROS)) + ((access initialize-package! + (->environment '(COMPILER DISASSEMBLER MACROS)))))) + +;; Load the assembler instruction database. +(in-package (->environment '(COMPILER LAP-SYNTAXER)) + (if (and compiler:enable-expansion-declarations? + (null? early-instructions)) + (fluid-let ((load-noisily? false)) + (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")) + '("insutl" "instr1" "instr2" "instr3"))))) + +;; Resyntax any files that need it. +((access syntax-files! (->environment '(COMPILER)))) + +(define (link-file from to #!optional physical?) + ((make-primitive-procedure 'LINK-FILE) + (canonicalize-input-filename from) + (canonicalize-output-filename to) + (and (not (default-object? physical?)) physical?))) + +(define (unix-rename-file from to) + (if (file-exists? to) + (delete-file to)) + (link-file from to true) + (delete-file from)) + +;; Rebuild the package constructors and cref. +(dynamic-wind + (lambda () + (link-file "machines/vax/comp.pkg" "comp.pkg" true)) + (lambda () + (cref/generate-all "comp") + (unix-rename-file "comp.cref" "machines/vax/comp.cref") + (unix-rename-file "comp.con" "machines/vax/comp.con") + (unix-rename-file "comp.ldr" "machines/vax/comp.ldr") + (unix-rename-file "comp.glob" "machines/vax/comp.glob")) + (lambda () + (delete-file "comp.pkg"))) +(sf "machines/vax/comp.con" "comp.bcon") +(sf "machines/vax/comp.ldr" "comp.bldr") \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/rulfix.scm b/v7/src/compiler/machines/vax/rulfix.scm new file mode 100644 index 000000000..0fe74701d --- /dev/null +++ b/v7/src/compiler/machines/vax/rulfix.scm @@ -0,0 +1,648 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rulfix.scm,v 1.1 1989/05/17 20:31:32 jinx Rel $ +$MC68020-Header: rules1.scm,v 4.22 89/04/27 20:06:32 GMT cph Exp $ + +Copyright (c) 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Fixnum operations. DEC VAX version. + +;;; Note: This corresponds to part of rules1 for MC68020. +;;; Hopefully the MC68020 version will be split along the +;;; same lines. + +(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)) + +(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)))) + +(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 (OFFSET (REGISTER (? a)) (? n)) + (FIXNUM->OBJECT (REGISTER (? source)))) + (let ((target (indirect-reference! a n))) + (register-fixnum->temp->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)))) + +(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-integrable (fixnum-1-arg target source operation) + (fixnum-choose-target + target + (lambda (target) + (with-register-copy-if-available source 'GENERAL target + (lambda (get-target) + (let ((target (get-target))) + (operation target target))) + (lambda () + (let* ((source (standard-fixnum-reference source)) + (target (standard-target-reference target))) + (operation target source))))) + (lambda (target) + (operation target (standard-fixnum-reference source))))) + +(define-integrable (fixnum-2-args target source1 source2 operation) + (fixnum-choose-target + target + (lambda (target) + (with-register-copy-if-available source1 'GENERAL target + (lambda (get-target) + (let* ((source2 (standard-fixnum-reference source2)) + (target (get-target))) + (operation target target source2))) + (lambda () + (with-register-copy-if-available source2 'GENERAL target + (lambda (get-target) + (let* ((source1 (standard-fixnum-reference source1)) + (target (get-target))) + (operation target source1 target))) + (lambda () + (let* ((source1 (standard-fixnum-reference source1)) + (source2 (standard-fixnum-reference source2)) + (target (standard-target-reference target))) + (operation target source1 source2))))))) + (lambda (target) + (let* ((source1 (standard-fixnum-reference source1)) + (source2 (standard-fixnum-reference source2))) + (operation target source1 source2))))) + +;;;; Operation rules + +(define-rule statement + (ASSIGN (? target) (FIXNUM-1-ARG (? operator) (REGISTER (? source)))) + (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source))) + (fixnum-1-arg target source (fixnum-1-arg/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))) + (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))) + (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))) + (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))) + (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)) + (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)) + (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))) + +(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))) + +(define-rule statement + (ASSIGN (OFFSET (REGISTER (? base)) (? offset)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (REGISTER (? source1)) + (REGISTER (? source2)))) + (QUALIFIER (and (pseudo-register? source1) + (pseudo-register? source2))) + (let ((target (indirect-reference! base offset))) + (with-temporary-copy-if-available source1 'GENERAL + (lambda (get-temp) + (let* ((source2 (standard-fixnum-reference source2)) + (temp (get-temp))) + (LAP (ASH L (& -8) ,temp ,temp) + (MUL L ,temp ,source2 ,target)))) + (lambda () + (with-temporary-copy-if-available source2 'GENERAL + (lambda (get-temp) + (let* ((source1 (standard-fixnum-reference source1)) + (temp (get-temp))) + (LAP (ASH L (& -8) ,temp ,temp) + (MUL L ,source1 ,temp ,target)))) + (lambda () + (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))))))))) + +;;;; 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))) + +(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))) + +(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))) + (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))) + (compare/register*memory + register + (predicate/memory-operand-reference memory) + (invert-cc-noncommutative (fixnum-predicate->cc predicate)))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) (? memory-1) (? memory-2)) + (QUALIFIER (and (predicate/memory-operand? memory-1) + (predicate/memory-operand? memory-2))) + (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) + (OBJECT->FIXNUM (CONSTANT (? constant)))) + (QUALIFIER (predicate/memory-operand? memory)) + (fixnum-predicate/memory*constant (predicate/memory-operand-reference memory) + constant + (fixnum-predicate->cc predicate))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (? memory)) + (QUALIFIER (predicate/memory-operand? memory)) + (fixnum-predicate/memory*constant + (predicate/memory-operand-reference memory) + constant + (invert-cc-noncommutative (fixnum-predicate->cc predicate)))) \ No newline at end of file