--- /dev/null
+#| -*-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
+\f
+(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?))
+\f
+(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))
+\f
+(define-package (compiler debug)
+ (files "base/debug")
+ (parent (compiler))
+ (export ()
+ compiler:write-rtl-file
+ debug/find-continuation
+ debug/find-entry-node
+ debug/find-procedure
+ 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))
+\f
+(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-procedure<?
+
+ make-dbg-continuation
+ dbg-continuation/block
+ dbg-continuation/label
+ set-dbg-continuation/label!
+ dbg-continuation<?
+
+ make-dbg-block
+ dbg-block/parent
+ dbg-block/layout
+ dbg-block/stack-link
+ set-dbg-block/procedure!
+
+ make-dbg-variable
+ dbg-variable/value
+ set-dbg-variable/value!
+
+ dbg-block-name/dynamic-link
+ dbg-block-name/ic-parent
+ dbg-block-name/normal-closure
+ dbg-block-name/return-address
+ dbg-block-name/static-link
+
+ make-dbg-label
+ dbg-label/names
+ set-dbg-label/names!
+ dbg-label/offset
+ set-dbg-label/name!
+ set-dbg-label/external?!))
+
+(define-package (compiler constraints)
+ (files "base/constr")
+ (parent (compiler))
+ (export (compiler)
+ make-constraint
+ constraint/element
+ constraint/graph-head
+ constraint/afters
+ constraint/closed?
+ constraint-add!
+ add-constraint-element!
+ add-constraint-set!
+ make-constraint-graph
+ constraint-graph/entry-nodes
+ constraint-graph/closed?
+ close-constraint-graph!
+ close-constraint-node!
+ order-per-constraints
+ order-per-constraints/extracted
+ legal-ordering-per-constraints?
+ with-new-constraint-marks
+ constraint-marked?
+ constraint-mark!
+ transitively-close-dag!
+ reverse-postorder))
+\f
+(define-package (compiler fg-generator)
+ (files "fggen/canon" ;SCode canonicalizer
+ "fggen/fggen" ;SCode->flow-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))
+\f
+(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))
+\f
+(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))
+\f
+(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))
+\f
+(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
--- /dev/null
+#| -*-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
+\f
+;; 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
--- /dev/null
+#| -*-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))
+\f
+;;;; Utilities
+
+(define-integrable (standard-fixnum-reference reg)
+ (standard-register-reference reg false))
+
+(define (signed-fixnum? n)
+ (and (integer? n)
+ (>= n signed-fixnum/lower-limit)
+ (< n signed-fixnum/upper-limit)))
+
+(define (unsigned-fixnum? n)
+ (and (integer? n)
+ (not (negative? n))
+ (< n unsigned-fixnum/upper-limit)))
+
+(define (guarantee-signed-fixnum n)
+ (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
+ n)
+
+(define (guarantee-unsigned-fixnum n)
+ (if (not (unsigned-fixnum? n)) (error "Not a unsigned fixnum" n))
+ n)
+
+(define (load-fixnum-constant constant register-reference)
+ (cond ((zero? constant)
+ (INST (CLR L ,register-reference)))
+ ((and (positive? constant) (< constant 64))
+ (INST (ASH L (S 8) (S ,constant) ,register-reference)))
+ (else
+ (let* ((constant (* constant #x100))
+ (size (datum-size constant)))
+ (cond ((not (eq? size 'L))
+ (INST (CVT ,size L (& ,constant) ,register-reference)))
+ ((and (positive? constant) (< constant #x10000))
+ (INST (MOVZ W L (& ,constant) ,register-reference)))
+ (else
+ (INST (MOV L (& ,constant) ,register-reference))))))))
+
+(define (test-fixnum effective-address)
+ (INST (TST L ,effective-address)))
+
+(define (fixnum-predicate->cc predicate)
+ (case predicate
+ ((EQUAL-FIXNUM? ZERO-FIXNUM?) 'EQL)
+ ((LESS-THAN-FIXNUM? NEGATIVE-FIXNUM?) 'LSS)
+ ((GREATER-THAN-FIXNUM? POSITIVE-FIXNUM?) 'GTR)
+ (else (error "FIXNUM-PREDICATE->CC: Unknown predicate" predicate))))
+
+(define (fixnum-operation-target? target)
+ (or (rtl:register? target)
+ (rtl:offset? target)))
+\f
+;;;; Fixnum operation dispatch
+
+(define (define-fixnum-method operator methods method)
+ (let ((entry (assq operator (cdr methods))))
+ (if entry
+ (set-cdr! entry method)
+ (set-cdr! methods (cons (cons operator method) (cdr methods)))))
+ operator)
+
+(define (lookup-fixnum-method operator methods)
+ (cdr (or (assq operator (cdr methods))
+ (error "Unknown operator" operator))))
+
+(define fixnum-methods/1-arg
+ (list 'FIXNUM-METHODS/1-ARG))
+
+(define-integrable (fixnum-1-arg/operate operator)
+ (lookup-fixnum-method operator fixnum-methods/1-arg))
+
+(define fixnum-methods/2-args
+ (list 'FIXNUM-METHODS/2-ARGS))
+
+(define-integrable (fixnum-2-args/operate operator)
+ (lookup-fixnum-method operator fixnum-methods/2-args))
+
+(define fixnum-methods/2-args-constant
+ (list 'FIXNUM-METHODS/2-ARGS-CONSTANT))
+
+(define-integrable (fixnum-2-args/operate-constant operator)
+ (lookup-fixnum-method operator fixnum-methods/2-args-constant))
+
+(define fixnum-methods/2-args-tnatsnoc
+ (list 'FIXNUM-METHODS/2-ARGS-TNATSNOC))
+
+(define-integrable (fixnum-2-args/operate-tnatsnoc operator)
+ (lookup-fixnum-method operator fixnum-methods/2-args-tnatsnoc))
+
+(define-integrable (fixnum-2-args/commutative? operator)
+ (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
+\f
+;;;; Data conversion
+
+(define-integrable (object->fixnum source reg-ref)
+ (LAP (ASH L (S 8) ,source ,reg-ref)))
+
+(define-integrable (ct/object->fixnum object target)
+ (LAP ,(load-fixnum-constant object target)))
+
+(define-integrable (address->fixnum source reg-ref)
+ (LAP (ASH L (S 8) ,source ,reg-ref)))
+
+(define-integrable (ct/address->fixnum address target)
+ (LAP ,(load-fixnum-constant (object-datum address) target)))
+
+(define-integrable (fixnum->address source reg-ref)
+ ;; This assumes that the low bits have 0s.
+ (LAP (ROTL (& -8) ,source ,reg-ref)))
+
+(define-integrable (ct/fixnum->address fixnum target)
+ (LAP ,(load-immediate fixnum target)))
+
+(define (fixnum->object source reg-ref target)
+ (if (eq? source reg-ref)
+ (LAP (MOV B (S ,(ucode-type fixnum)) ,reg-ref)
+ (ROTL (& -8) ,reg-ref ,target))
+ ;; This assumes that the low 8 bits are 0
+ (LAP (BIS L (S ,(ucode-type fixnum)) ,source ,reg-ref)
+ (ROTL (& -8) ,reg-ref ,target))))
+
+(define-integrable (ct/fixnum->object fixnum target)
+ (LAP ,(load-constant fixnum target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (CONSTANT (? constant)))))
+ (QUALIFIER (pseudo-register? target))
+ (convert-object/constant->register target constant
+ address->fixnum
+ ct/address->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
+ (QUALIFIER (pseudo-register? target))
+ (convert-object/register->register target source address->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (OFFSET (REGISTER (? address))
+ (? offset)))))
+ (QUALIFIER (pseudo-register? target))
+ (convert-object/offset->register target address offset address->fixnum))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (QUALIFIER (pseudo-register? target))
+ (load-fixnum-constant constant (standard-target-reference target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (convert-object/register->register target source object->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (convert-object/register->register target source address->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset))))
+ (QUALIFIER (pseudo-register? target))
+ (convert-object/offset->register target address offset object->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (convert-object/register->register
+ target source
+ (lambda (source target)
+ (fixnum->object source target target))))
+
+(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))))
+\f
+;;;; Arithmetic operations
+
+(define-fixnum-method 'PLUS-FIXNUM fixnum-methods/2-args
+ (lambda (target source1 source2)
+ (cond ((eq? source1 target)
+ (LAP (ADD L ,source2 ,target)))
+ ((eq? source2 target)
+ (LAP (ADD L ,source1 ,target)))
+ (else
+ (LAP (ADD L ,source1 ,source2 ,target))))))
+
+(define-fixnum-method 'PLUS-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (cond ((eq? source target)
+ (if (zero? n)
+ (LAP)
+ (LAP (ADD L (& ,(* n #x100)) ,target))))
+ ((zero? n)
+ (LAP (MOV L ,source ,target)))
+ (else
+ (LAP (ADD L (& ,(* n #x100)) ,source ,target))))))
+
+(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
+ (lambda (target source1 source2)
+ (cond ((eq? source1 target)
+ (if (equal? source1 source2)
+ (LAP (ASH L (& -4) ,target ,target)
+ (MUL L ,target ,target))
+ (LAP (ASH L (& -8) ,target ,target)
+ (MUL L ,source2 ,target))))
+ ((eq? source2 target)
+ (LAP (ASH L (& -8) ,target ,target)
+ (MUL L ,source1 ,target)))
+ (else
+ (LAP (ASH L (& -8) ,source1 ,target)
+ (MUL L ,source2 ,target))))))
+
+(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (cond ((zero? n)
+ (LAP (CLR L ,target)))
+ ((eq? source target)
+ (cond ((= n 1)
+ (LAP))
+ ((= n -1)
+ (LAP (MNEG L ,target ,target)))
+ ((integer-log-base-2? n)
+ =>
+ (lambda (power-of-2)
+ (LAP (ASH L ,(make-immediate power-of-2)
+ ,target ,target))))
+ (else
+ (LAP (MUL L ,(make-immediate n) ,target)))))
+ ((= n 1)
+ (MOV L ,source ,target))
+ ((= n -1)
+ (LAP (MNEG L ,source ,target)))
+ ((integer-log-base-2? n)
+ =>
+ (lambda (power-of-2)
+ (LAP (ASH L ,(make-immediate power-of-2) ,source ,target))))
+ (else
+ (LAP (MUL L ,(make-immediate n) ,source ,target))))))
+
+(define (integer-log-base-2? n)
+ (let loop ((power 1) (exponent 0))
+ (cond ((< n power) false)
+ ((= n power) exponent)
+ (else (loop (* 2 power) (1+ exponent))))))
+\f
+(define-fixnum-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target source)
+ (if (eq? source target)
+ (LAP (ADD L (& #x100) ,target))
+ (LAP (ADD L (& #x100) ,source ,target)))))
+
+(define-fixnum-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target source)
+ (if (eq? source target)
+ (LAP (SUB L (& #x100) ,target))
+ (LAP (SUB L (& #x100) ,source ,target)))))
+
+(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args
+ (lambda (target source1 source2)
+ (cond ((equal? source1 source2)
+ (LAP (CLR L ,target)))
+ ((eq? source1 target)
+ (LAP (SUB L ,source2 ,target)))
+ (else
+ (LAP (SUB L ,source2 ,source1 ,target))))))
+
+(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target source n)
+ (cond ((eq? source target)
+ (if (zero? n)
+ (LAP)
+ (LAP (SUB L (& ,(* n #x100)) ,target))))
+ ((zero? n)
+ (LAP (MOV L ,source ,target)))
+ (else
+ (LAP (SUB L (& ,(* n #x100)) ,source ,target))))))
+
+(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-tnatsnoc
+ (lambda (target n source)
+ (if (zero? n)
+ (LAP (MNEG L ,source ,target))
+ (LAP (SUB L ,source (& ,(* n #x100)) ,target)))))
+\f
+;;;; Operation utilities
+
+(define (fixnum-choose-target target operate-on-pseudo operate-on-target)
+ (case (rtl:expression-type target)
+ ((REGISTER)
+ (let ((register (rtl:register-number target)))
+ (if (pseudo-register? register)
+ (operate-on-pseudo register)
+ (operate-on-target (register-reference register)))))
+ ((OFFSET)
+ (operate-on-target (offset->indirect-reference! target)))
+ (else
+ (error "fixnum-choose-target: Unknown fixnum target" target))))
+
+(define-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)))))
+\f
+;;;; 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))))
+\f
+;;; This code is disabled on the MC68020 because of shifting problems.
+;; The constant 4 is treated especially because it appears in computed
+;; vector-{ref,set!} operations.
+
+(define (convert-index->fixnum/register target source)
+ (fixnum-1-arg
+ target source
+ (lambda (target source)
+ (LAP (ASH L (S 10) ,source ,target)))))
+
+(define-rule statement
+ (ASSIGN (? target)
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (CONSTANT 4))
+ (OBJECT->FIXNUM (REGISTER (? source)))))
+ (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (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))
+\f
+;;;; General 2 operand rules
+
+(define-rule statement
+ (ASSIGN (? target)
+ (FIXNUM-2-ARGS (? operator)
+ (REGISTER (? source1))
+ (REGISTER (? source2))))
+ (QUALIFIER (and (fixnum-operation-target? target)
+ (not (eq? operator 'MULTIPLY-FIXNUM))
+ (pseudo-register? source1)
+ (pseudo-register? source2)))
+ (fixnum-2-args target source1 source2 (fixnum-2-args/operate operator)))
+
+(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)))))))))
+\f
+;;;; Fixnum Predicates
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
+ (QUALIFIER (pseudo-register? register))
+ (set-standard-branches! (fixnum-predicate->cc predicate))
+ (test-fixnum (standard-fixnum-reference register)))
+
+(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)))
+\f
+(define (fixnum-predicate/register*constant register constant cc)
+ (set-standard-branches! cc)
+ (guarantee-signed-fixnum constant)
+ (if (zero? constant)
+ (LAP ,(test-fixnum (standard-fixnum-reference register)))
+ (LAP (CMP L ,(standard-fixnum-reference register)
+ (& ,(* constant #x100))))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? register))
+ (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (QUALIFIER (pseudo-register? register))
+ (fixnum-predicate/register*constant register
+ constant
+ (fixnum-predicate->cc predicate)))
+
+(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
projects / mit-scheme.git / commitdiff