--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/assmd.scm,v 1.1 1990/05/07 04:10:19 jinx Rel $
+$MC68020-Header: assmd.scm,v 1.36 89/08/28 18:33:33 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Assembler Machine Dependencies
+
+(declare (usual-integrations))
+\f
+(let-syntax ((ucode-type (macro (name) `',(microcode-type name))))
+
+(define-integrable maximum-padding-length
+ ;; Instruction length is always a multiple of 32 bits
+ ;; Would 0 work here?
+ 32)
+
+(define padding-string
+ ;; Pad with `DIAG SCM' instructions
+ (unsigned-integer->bit-string maximum-padding-length
+ #b00010100010100110100001101001101))
+
+(define-integrable block-offset-width
+ ;; Block offsets are always 16 bit words
+ 16)
+
+(define-integrable maximum-block-offset
+ ;; PC always aligned on longword boundary. Use the extra bit.
+ (- (expt 2 (1+ block-offset-width)) 4))
+
+(define (block-offset->bit-string offset start?)
+ (unsigned-integer->bit-string block-offset-width
+ (+ (quotient offset 2)
+ (if start? 0 1))))
+
+(define (make-nmv-header n)
+ (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
+ nmv-type-string))
+
+(define nmv-type-string
+ (unsigned-integer->bit-string scheme-type-width
+ (ucode-type manifest-nm-vector)))
+
+(define (object->bit-string object)
+ (bit-string-append
+ (unsigned-integer->bit-string scheme-datum-width
+ (careful-object-datum object))
+ (unsigned-integer->bit-string scheme-type-width (object-type object))))
+
+;;; Machine dependent instruction order
+
+(define-integrable (instruction-initial-position block)
+ block ; ignored
+ 0)
+
+(define (instruction-insert! bits block position receiver)
+ (let ((l (bit-string-length bits)))
+ (bit-substring-move-right! bits 0 l block position)
+ (receiver (+ position l))))
+
+(define-integrable instruction-append
+ bit-string-append)
+
+;;; end let-syntax
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/coerce.scm,v 1.1 1990/05/07 04:10:32 jinx Rel $
+$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 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. |#
+
+(declare (usual-integrations))
+\f
+;;;; MIPS coercions
+
+;;; Coercion top level
+
+(define make-coercion
+ (coercion-maker
+ `((UNSIGNED . ,coerce-unsigned-integer)
+ (SIGNED . ,coerce-signed-integer))))
+
+(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1))
+(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4))
+(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
+(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
+(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10))
+(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11))
+(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15))
+(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
+(define coerce-20-bit-unsigned (make-coercion 'UNSIGNED 20))
+(define coerce-25-bit-unsigned (make-coercion 'UNSIGNED 25))
+(define coerce-26-bit-unsigned (make-coercion 'UNSIGNED 26))
+(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
+
+(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
+(define coerce-26-bit-signed (make-coercion 'SIGNED 26))
+(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/compiler.cbf,v 1.1 1990/05/07 04:11:13 jinx Rel $
+
+Copyright (c) 1988, 1989, 1990 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 compile the compiler (from .bins)
+
+(for-each compile-directory
+ '("back"
+ "base"
+ "fggen"
+ "fgopt"
+ "machines/mips"
+ "rtlbase"
+ "rtlgen"
+ "rtlopt"))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/compiler.pkg,v 1.1 1990/05/07 04:11:31 jinx Exp $
+$MC68020-Header: comp.pkg,v 1.27 90/01/22 23:45:02 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 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 "../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
+ "rtlbase/valclass" ;RTL: value classes
+ "machines/mips/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:compile-by-procedures?
+ compiler:cse?
+ compiler:default-top-level-declarations
+ compiler:enable-expansion-declarations?
+ compiler:enable-integration-declarations?
+ compiler:generate-lap-files?
+ compiler:generate-range-checks?
+ compiler:generate-rtl-files?
+ compiler:generate-type-checks?
+ compiler:implicit-self-static?
+ compiler:noisy?
+ compiler:open-code-flonum-checks?
+ compiler:open-code-primitives?
+ compiler:optimize-environments?
+ compiler:package-optimization-level
+ compiler:preserve-data-structures?
+ compiler:show-phases?
+ compiler:show-procedures?
+ compiler:show-subphases?
+ compiler:show-time-reports?))
+\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/mips/decls")
+ (parent (compiler))
+ (export (compiler)
+ sc
+ syntax-files!)
+ (import (scode-optimizer top-level)
+ sf/internal)
+ (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)
+ *block-label*
+ *external-labels*
+ label->object)
+ (export (compiler debug)
+ *root-expression*
+ *rtl-procedures*
+ *rtl-graphs*)
+ (import (runtime compiler-info)
+ make-dbg-info-vector)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
+\f
+(define-package (compiler debug)
+ (files "base/debug")
+ (parent (compiler))
+ (export ()
+ 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
+ write-rtl-instructions)
+ (import (runtime pretty-printer)
+ *pp-primitives-by-name*)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-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-2
+ dbg-label/offset
+ 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 variable-indirection)
+ (files "fgopt/varind")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) initialize-variable-indirections!))
+
+(define-package (compiler fg-optimizer environment-optimization)
+ (files "fgopt/envopt")
+ (parent (compiler fg-optimizer))
+ (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
+ setup-block-static-links!))
+
+(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))
+
+(define-package (compiler fg-optimizer return-equivalencing)
+ (files "fgopt/reteqv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) find-equivalent-returns!))
+\f
+(define-package (compiler rtl-generator)
+ (files "rtlgen/rtlgen" ;RTL generator
+ "rtlgen/rgstmt" ;statements
+ "rtlgen/fndvar" ;find variables
+ "machines/mips/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 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)
+ (export (compiler rtl-generator combination/inline)
+ generate/invocation-prefix))
+
+(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 common-suffix-merging)
+ (files "rtlopt/rtlcsm")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) merge-common-suffixes!))
+
+(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
+ (files "rtlopt/rdflow")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) rtl-dataflow-analysis))
+
+(define-package (compiler rtl-optimizer rtl-rewriting)
+ (files "rtlopt/rerite")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level)
+ rtl-rewriting:post-cse
+ rtl-rewriting:pre-cse)
+ (export (compiler lap-syntaxer) add-rewriting-rule!))
+
+(define-package (compiler rtl-optimizer lifetime-analysis)
+ (files "rtlopt/rlife")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) lifetime-analysis)
+ (export (compiler rtl-optimizer code-compression) mark-set-registers!))
+
+(define-package (compiler rtl-optimizer code-compression)
+ (files "rtlopt/rcompr")
+ (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/mips/lapgen" ;code generation rules
+ "machines/mips/rules1" ; " " "
+ "machines/mips/rules2" ; " " "
+ "machines/mips/rules3" ; " " "
+ "machines/mips/rules4" ; " " "
+ "machines/mips/rulfix" ; " " "
+ "machines/mips/rulflo" ; " " "
+ "machines/mips/rulrew" ;code rewriting rules
+ "back/syntax" ;Generic syntax phase
+ "back/syerly" ;Early binding version
+ "machines/mips/coerce" ;Coercions: integer -> bit string
+ "back/asmmac" ;Macros for hairy syntax
+ "machines/mips/insmac" ;Macros for hairy syntax
+ "machines/mips/inerly" ;Early binding version
+ "machines/mips/instr1" ;Mips instruction set
+ "machines/mips/instr2a"; branch tensioning: branches
+ "machines/mips/instr2b"; branch tensioning: load/store
+ "machines/mips/instr3" ; floating point
+ )
+ (parent (compiler))
+ (export (compiler)
+ fits-in-16-bits-signed?
+ fits-in-16-bits-unsigned?
+ top-16-bits-only?
+ lap-generator/match-rtl-instruction
+ lap:make-entry-point
+ lap:make-label-statement
+ lap:make-unconditional-branch
+ lap:syntax-instruction)
+ (export (compiler top-level)
+ *interned-assignments*
+ *interned-constants*
+ *interned-uuo-links*
+ *interned-variables*
+ *next-constant*
+ generate-lap)
+ (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-lap
+ bblock-linearize-lap)
+ (export (compiler top-level)
+ linearize-lap))
+
+(define-package (compiler assembler)
+ (files "machines/mips/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/mips/mips"
+ "machines/mips/dassm1"
+ "machines/mips/dassm2"
+ "machines/mips/dassm3")
+ (parent (compiler))
+ (export ()
+ compiler:write-lap-file
+ compiler:disassemble)
+ (import (runtime compiler-info)
+ compiled-code-block/dbg-info
+ dbg-info-vector/blocks-vector
+ dbg-info-vector?
+ dbg-info/labels
+ dbg-label/external?
+ dbg-label/name
+ dbg-labels/find-offset))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/compiler.sf-big,v 1.1 1990/05/07 04:11:47 jinx Rel $
+$MC68020-Header: comp.sf,v 1.11 89/08/28 18:33:37 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 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 "../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? "comp.bcon"))
+ (begin
+ ((access cref/generate-trivial-constructor
+ (->environment '(CROSS-REFERENCE)))
+ "comp")
+ (sf "comp.con" "comp.bcon")))
+ (load "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/mips/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 '("rtlbase/valclass") '(COMPILER))
+ (fluid-let ((sf/default-syntax-table
+ (access compiler-syntax-table
+ (->environment '(COMPILER MACROS)))))
+ (sf-and-load '("machines/mips/machin") '(COMPILER)))
+ (fluid-let ((sf/default-declarations
+ '((integrate-external "insseq")
+ (integrate-external "machin")
+ (usual-definition (set expt)))))
+ (sf-and-load '("machines/mips/assmd") '(COMPILER ASSEMBLER)))
+ (sf-and-load '("back/syntax")
+ '(COMPILER LAP-SYNTAXER))
+ (sf-and-load '("machines/mips/coerce" "back/asmmac"
+ "machines/mips/insmac")
+ '(COMPILER LAP-SYNTAXER))
+ (sf-and-load '("base/scode") '(COMPILER))
+ (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
+ (sf-and-load '("machines/mips/inerly" "back/syerly")
+ '(COMPILER LAP-SYNTAXER))))
+
+;; 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)
+ (load/suppress-loading-message? false))
+ (write-string "\n\n---- Pre-loading instruction sets ----")
+ (for-each (lambda (name)
+ (load (string-append "machines/mips/" name ".scm")
+ '(COMPILER LAP-SYNTAXER)
+ early-syntax-table))
+ '("instr1" "instr2a" "instr2b" "instr3")))))
+
+;; Resyntax any files that need it.
+((access syntax-files! (->environment '(COMPILER))))
+
+;; Rebuild the package constructors and cref.
+(cref/generate-all "comp")
+(sf "comp.con" "comp.bcon")
+(sf "comp.ldr" "comp.bldr")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/compiler.sf-little,v 1.1 1990/05/07 04:11:47 jinx Rel $
+$MC68020-Header: comp.sf,v 1.11 89/08/28 18:33:37 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 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 "../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? "comp.bcon"))
+ (begin
+ ((access cref/generate-trivial-constructor
+ (->environment '(CROSS-REFERENCE)))
+ "comp")
+ (sf "comp.con" "comp.bcon")))
+ (load "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/mips/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 '("rtlbase/valclass") '(COMPILER))
+ (fluid-let ((sf/default-syntax-table
+ (access compiler-syntax-table
+ (->environment '(COMPILER MACROS)))))
+ (sf-and-load '("machines/mips/machin") '(COMPILER)))
+ (fluid-let ((sf/default-declarations
+ '((integrate-external "insseq")
+ (integrate-external "machin")
+ (usual-definition (set expt)))))
+ (sf-and-load '("machines/mips/assmd") '(COMPILER ASSEMBLER)))
+ (sf-and-load '("back/syntax")
+ '(COMPILER LAP-SYNTAXER))
+ (sf-and-load '("machines/mips/coerce" "back/asmmac"
+ "machines/mips/insmac")
+ '(COMPILER LAP-SYNTAXER))
+ (sf-and-load '("base/scode") '(COMPILER))
+ (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
+ (sf-and-load '("machines/mips/inerly" "back/syerly")
+ '(COMPILER LAP-SYNTAXER))))
+
+;; 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)
+ (load/suppress-loading-message? false))
+ (write-string "\n\n---- Pre-loading instruction sets ----")
+ (for-each (lambda (name)
+ (load (string-append "machines/mips/" name ".scm")
+ '(COMPILER LAP-SYNTAXER)
+ early-syntax-table))
+ '("instr1" "instr2a" "instr2b" "instr3")))))
+
+;; Resyntax any files that need it.
+((access syntax-files! (->environment '(COMPILER))))
+
+;; Rebuild the package constructors and cref.
+(cref/generate-all "comp")
+(sf "comp.con" "comp.bcon")
+(sf "comp.ldr" "comp.bldr")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/dassm1.scm,v 1.1 1990/05/07 04:12:03 jinx Rel $
+$MC68020-Header: dassm1.scm,v 4.14 89/10/26 07:37:28 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Disassembler: User Level
+
+(declare (usual-integrations))
+\f
+;;; Flags that control disassembler behavior
+
+(define disassembler/symbolize-output? true)
+(define disassembler/compiled-code-heuristics? true)
+(define disassembler/write-offsets? true)
+(define disassembler/write-addresses? false)
+
+;;;; Top level entries
+
+(define (compiler:write-lap-file filename #!optional symbol-table?)
+ (let ((pathname (->pathname filename)))
+ (with-output-to-file (pathname-new-type pathname "lap")
+ (lambda ()
+ (let ((com-file (pathname-new-type pathname "com")))
+ (let ((object (fasload com-file))
+ (info
+ (let ((pathname (pathname-new-type pathname "binf")))
+ (and (if (default-object? symbol-table?)
+ (file-exists? pathname)
+ symbol-table?)
+ (fasload pathname)))))
+ (if (compiled-code-address? object)
+ (disassembler/write-compiled-code-block
+ (compiled-code-address->block object)
+ info)
+ (begin
+ (if (not
+ (and (scode/comment? object)
+ (dbg-info-vector? (scode/comment-text object))))
+ (error "Not a compiled file" com-file))
+ (let ((items
+ (vector->list
+ (dbg-info-vector/blocks-vector
+ (scode/comment-text object)))))
+ (if (not (null? items))
+ (if (false? info)
+ (let loop ((items items))
+ (disassembler/write-compiled-code-block
+ (car items)
+ false)
+ (if (not (null? (cdr items)))
+ (begin
+ (write-char #\page)
+ (loop (cdr items)))))
+ (let loop
+ ((items items) (info (vector->list info)))
+ (disassembler/write-compiled-code-block
+ (car items)
+ (car info))
+ (if (not (null? (cdr items)))
+ (begin
+ (write-char #\page)
+ (loop (cdr items) (cdr info))))))))))))))))
+
+(define disassembler/base-address)
+
+(define (compiler:disassemble entry)
+ (let ((block (compiled-entry/block entry)))
+ (let ((info (compiled-code-block/dbg-info block true)))
+ (fluid-let ((disassembler/write-offsets? true)
+ (disassembler/write-addresses? true)
+ (disassembler/base-address (object-datum block)))
+ (newline)
+ (newline)
+ (disassembler/write-compiled-code-block block info)))))
+\f
+;;; Operations exported from the disassembler package
+
+(define disassembler/instructions)
+(define disassembler/instructions/null?)
+(define disassembler/instructions/read)
+(define disassembler/lookup-symbol)
+(define disassembler/read-variable-cache)
+(define disassembler/read-procedure-cache)
+(define compiled-code-block/objects-per-procedure-cache)
+(define compiled-code-block/objects-per-variable-cache)
+
+(define (disassembler/write-compiled-code-block block info)
+ (let ((symbol-table (and info (dbg-info/labels info))))
+ (write-string "Disassembly of ")
+ (write block)
+ (write-string ":\n")
+ (write-string "Code:\n\n")
+ (disassembler/write-instruction-stream
+ symbol-table
+ (disassembler/instructions/compiled-code-block block symbol-table))
+ (write-string "\nConstants:\n\n")
+ (disassembler/write-constants-block block symbol-table)
+ (newline)))
+
+(define (disassembler/instructions/compiled-code-block block symbol-table)
+ (disassembler/instructions block
+ (compiled-code-block/code-start block)
+ (compiled-code-block/code-end block)
+ symbol-table))
+
+(define (disassembler/instructions/address start-address end-address)
+ (disassembler/instructions false start-address end-address false))
+
+(define (disassembler/write-instruction-stream symbol-table instruction-stream)
+ (fluid-let ((*unparser-radix* 16))
+ (disassembler/for-each-instruction instruction-stream
+ (lambda (offset instruction)
+ (disassembler/write-instruction symbol-table
+ offset
+ (lambda () (display instruction)))))))
+
+(define (disassembler/for-each-instruction instruction-stream procedure)
+ (let loop ((instruction-stream instruction-stream))
+ (if (not (disassembler/instructions/null? instruction-stream))
+ (disassembler/instructions/read instruction-stream
+ (lambda (offset instruction instruction-stream)
+ (procedure offset instruction)
+ (loop (instruction-stream)))))))
+\f
+(define (disassembler/write-constants-block block symbol-table)
+ (fluid-let ((*unparser-radix* 16))
+ (let ((end (system-vector-length block)))
+ (let loop ((index (compiled-code-block/constants-start block)))
+ (cond ((not (< index end)) 'DONE)
+ ((object-type?
+ (let-syntax ((ucode-type
+ (macro (name) (microcode-type name))))
+ (ucode-type linkage-section))
+ (system-vector-ref block index))
+ (loop (disassembler/write-linkage-section block
+ symbol-table
+ index)))
+ (else
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-constant block
+ symbol-table
+ (system-vector-ref block index))))
+ (loop (1+ index))))))))
+
+(define (write-constant block symbol-table constant)
+ (write-string (cdr (write-to-string constant 60)))
+ (cond ((lambda? constant)
+ (let ((expression (lambda-body constant)))
+ (if (and (compiled-code-address? expression)
+ (eq? (compiled-code-address->block expression) block))
+ (begin
+ (write-string " (")
+ (let ((offset (compiled-code-address->offset expression)))
+ (let ((label
+ (disassembler/lookup-symbol symbol-table offset)))
+ (if label
+ (write-string label)
+ (write offset))))
+ (write-string ")")))))
+ ((compiled-code-address? constant)
+ (write-string " (offset ")
+ (write (compiled-code-address->offset constant))
+ (write-string " in ")
+ (write (compiled-code-address->block constant))
+ (write-string ")"))
+ (else false)))
+\f
+(define (disassembler/write-linkage-section block symbol-table index)
+ (define (write-caches index size how-many writer)
+ (let loop ((index index) (how-many how-many))
+ (if (zero? how-many)
+ 'DONE
+ (begin
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (writer block index)))
+ (loop (+ size index) (-1+ how-many))))))
+
+ (let* ((field (object-datum (system-vector-ref block index)))
+ (descriptor (integer-divide field #x10000)))
+ (let ((kind (integer-divide-quotient descriptor))
+ (length (integer-divide-remainder descriptor)))
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-string "#[LINKAGE-SECTION ")
+ (write field)
+ (write-string "]")))
+ (write-caches
+ (1+ index)
+ compiled-code-block/objects-per-procedure-cache
+ (quotient length compiled-code-block/objects-per-procedure-cache)
+ (case kind
+ ((0)
+ disassembler/write-procedure-cache)
+ ((1)
+ (lambda (block index)
+ (disassembler/write-variable-cache "Reference" block index)))
+ ((2)
+ (lambda (block index)
+ (disassembler/write-variable-cache "Assignment" block index)))
+ (else
+ (error "disassembler/write-linkage-section: Unknown section kind"
+ kind))))
+ (1+ (+ index length)))))
+\f
+(define-integrable (variable-cache-name cache)
+ ((ucode-primitive primitive-object-ref 2) cache 1))
+
+(define (disassembler/write-variable-cache kind block index)
+ (write-string kind)
+ (write-string " cache to ")
+ (write (variable-cache-name (disassembler/read-variable-cache block index))))
+
+(define (disassembler/write-procedure-cache block index)
+ (let ((result (disassembler/read-procedure-cache block index)))
+ (write (vector-ref result 2))
+ (write-string " argument procedure cache to ")
+ (case (vector-ref result 0)
+ ((COMPILED INTERPRETED)
+ (write (vector-ref result 1)))
+ ((VARIABLE)
+ (write-string "variable ")
+ (write (vector-ref result 1)))
+ (else
+ (error "disassembler/write-procedure-cache: Unknown cache kind"
+ (vector-ref result 0))))))
+
+(define (disassembler/write-instruction symbol-table offset write-instruction)
+ (if symbol-table
+ (let ((label (dbg-labels/find-offset symbol-table offset)))
+ (if label
+ (begin
+ (write-char #\Tab)
+ (write-string (dbg-label/name label))
+ (write-char #\:)
+ (newline)))))
+
+ (if disassembler/write-addresses?
+ (begin
+ (write-string
+ (number->string (+ offset disassembler/base-address) 16))
+ (write-char #\Tab)))
+
+ (if disassembler/write-offsets?
+ (begin
+ (write-string (number->string offset 16))
+ (write-char #\Tab)))
+
+ (if symbol-table
+ (write-string " "))
+ (write-instruction)
+ (newline))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/dassm2.scm,v 1.1 1990/05/07 04:12:17 jinx Rel $
+$MC68020-Header: dassm2.scm,v 4.16 89/12/11 06:16:42 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 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. |#
+
+;;;; MIPS Disassembler: Top Level
+
+(declare (usual-integrations))
+\f
+(set! compiled-code-block/bytes-per-object 4)
+(set! compiled-code-block/objects-per-procedure-cache 2)
+(set! compiled-code-block/objects-per-variable-cache 1)
+
+(set! disassembler/read-variable-cache
+ (lambda (block index)
+ (let-syntax ((ucode-type
+ (macro (name) (microcode-type name)))
+ (ucode-primitive
+ (macro (name arity)
+ (make-primitive-procedure name arity))))
+ ((ucode-primitive primitive-object-set-type 2)
+ (ucode-type quad)
+ (system-vector-ref block index)))))
+
+(set! disassembler/read-procedure-cache
+ (lambda (block index)
+ (fluid-let ((*block block))
+ (let* ((offset (compiled-code-block/index->offset index)))
+ offset
+ ;; For now
+ (error "disassembler/read-procedure-cache: Not written")))))
+\f
+(set! disassembler/instructions
+ (lambda (block start-offset end-offset symbol-table)
+ (let loop ((offset start-offset) (state (disassembler/initial-state)))
+ (if (and end-offset (< offset end-offset))
+ (disassemble-one-instruction block offset symbol-table state
+ (lambda (offset* instruction state)
+ (make-instruction offset
+ instruction
+ (lambda () (loop offset* state)))))
+ '()))))
+
+(set! disassembler/instructions/null?
+ null?)
+
+(set! disassembler/instructions/read
+ (lambda (instruction-stream receiver)
+ (receiver (instruction-offset instruction-stream)
+ (instruction-instruction instruction-stream)
+ (instruction-next instruction-stream))))
+
+(define-structure (instruction (type vector))
+ (offset false read-only true)
+ (instruction false read-only true)
+ (next false read-only true))
+
+(define *block)
+(define *current-offset)
+(define *symbol-table)
+(define *ir)
+(define *valid?)
+
+(define (disassemble-one-instruction block offset symbol-table state receiver)
+ (fluid-let ((*block block)
+ (*current-offset offset)
+ (*symbol-table symbol-table)
+ (*ir)
+ (*valid? true))
+ (set! *ir (get-longword))
+ (let ((start-offset *current-offset))
+ (if (external-label-marker? symbol-table offset state)
+ (receiver *current-offset
+ (make-external-label *ir)
+ 'INSTRUCTION)
+ (let ((instruction (disassemble-word *ir)))
+ (if (not *valid?)
+ (let ((inst (make-word *ir)))
+ (receiver start-offset
+ inst
+ (disassembler/next-state inst state)))
+ (let ((next-state (disassembler/next-state instruction state)))
+ (receiver
+ *current-offset
+ (cond ((and (pair? state)
+ (eq? (car state) 'PC-REL-LOW-OFFSET))
+ (pc-relative-inst offset instruction (cadr state)))
+ ((and (eq? 'PC-REL-OFFSET state)
+ (not (pair? next-state)))
+ (pc-relative-inst offset instruction false))
+ (else
+ instruction))
+ next-state))))))))
+\f
+(define (pc-relative-inst start-address instruction left-side)
+ (let ((opcode (car instruction)))
+ (if (not (memq opcode '(LDO LDW)))
+ instruction
+ (let ((offset-exp (caddr instruction))
+ (target (cadddr instruction)))
+ (let ((offset (cadr offset-exp))
+ (space-reg (caddr offset-exp))
+ (base-reg (cadddr offset-exp)))
+ (let* ((real-address
+ (+ start-address
+ offset
+ (if (not left-side)
+ 0
+ (- (let ((val (* left-side #x800)))
+ (if (>= val #x80000000)
+ (- val #x100000000)
+ val))
+ 4))))
+ (label
+ (disassembler/lookup-symbol *symbol-table real-address)))
+ (if (not label)
+ instruction
+ `(,opcode () (OFFSET ,(if left-side
+ `(RIGHT (- ,label (- *PC* 4)))
+ `(- ,label *PC*))
+ ,space-reg
+ ,base-reg)
+ ,target))))))))
+
+(define (disassembler/initial-state)
+ 'INSTRUCTION-NEXT)
+
+(define (disassembler/next-state instruction state)
+ (cond ((not disassembler/compiled-code-heuristics?)
+ 'INSTRUCTION)
+ ((and (eq? state 'INSTRUCTION)
+ (equal? instruction '(BL () 1 (@PCO 0))))
+ 'PC-REL-DEP)
+ ((and (eq? state 'PC-REL-DEP)
+ (equal? instruction '(DEP () 0 31 2 1)))
+ 'PC-REL-OFFSET)
+ ((and (eq? state 'PC-REL-OFFSET)
+ (= (length instruction) 4)
+ (equal? (list (car instruction)
+ (cadr instruction)
+ (cadddr instruction))
+ '(ADDIL () 1)))
+ (list 'PC-REL-LOW-OFFSET (caddr instruction)))
+ ((memq (car instruction) '(B BV BLE))
+ 'EXTERNAL-LABEL)
+ (else
+ 'INSTRUCTION)))
+\f
+(set! disassembler/lookup-symbol
+ (lambda (symbol-table offset)
+ (and symbol-table
+ (let ((label (dbg-labels/find-offset symbol-table offset)))
+ (and label
+ (dbg-label/name label))))))
+
+(define (external-label-marker? symbol-table offset state)
+ (if symbol-table
+ (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
+ (and label
+ (dbg-label/external? label)))
+ (and *block
+ (not (eq? state 'INSTRUCTION))
+ (let loop ((offset (+ offset 4)))
+ (let ((contents (read-bits (- offset 2) 16)))
+ (if (bit-string-clear! contents 0)
+ (let ((offset
+ (- offset (* 2 (bit-string->unsigned-integer contents)))))
+ (and (positive? offset)
+ (loop offset)))
+ (= offset (* 2 (bit-string->unsigned-integer contents)))))))))
+
+(define (make-word bit-string)
+ `(UWORD ,(bit-string->unsigned-integer bit-string)))
+
+(define (make-external-label bit-string)
+ `(EXTERNAL-LABEL
+ (FORMAT ,(extract bit-string 0 16))
+ (@PCO ,(* 4 (extract-signed bit-string 16 32)))))
+
+#|
+;;; 68k version
+
+(define (read-procedure offset)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let-syntax ((ucode-type
+ (macro (name) (microcode-type name)))
+ (ucode-primitive
+ (macro (name arity)
+ (make-primitive-procedure name arity))))
+ ((ucode-primitive primitive-object-set-type 2)
+ (ucode-type compiled-entry)
+ ((ucode-primitive make-non-pointer-object 1)
+ (read-unsigned-integer offset 32)))))))
+|#
+
+(define (read-procedure offset)
+ (error "read-procedure: Called" offset))
+
+(define (read-unsigned-integer offset size)
+ (bit-string->unsigned-integer (read-bits offset size)))
+
+(define (read-bits offset size-in-bits)
+ (let ((word (bit-string-allocate size-in-bits))
+ (bit-offset (* offset addressing-granularity)))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (if *block
+ (read-bits! *block bit-offset word)
+ (read-bits! offset 0 word))))
+ word))
+
+(define (invalid-instruction)
+ (set! *valid? false)
+ false)
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/dassm3.scm,v 1.1 1990/05/07 04:12:32 jinx Rel $
+
+Copyright (c) 1987, 1989, 1990 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. |#
+
+;;; MIPS Disassembler: Internals
+
+(declare (usual-integrations))
+\f
+;;;; Utilities
+
+(define (get-longword)
+ (let ((word (read-bits *current-offset 32)))
+ (set! *current-offset (+ *current-offset 4))
+ word))
+
+(declare (integrate-operator extract))
+(declare (integrate-operator extract-signed))
+
+(define (extract bit-string start end)
+ (declare (integrate bit-string start end))
+ (bit-string->unsigned-integer (bit-substring bit-string start end)))
+
+(define (extract-signed bit-string start end)
+ (declare (integrate bit-string start end))
+ (bit-string->signed-integer (bit-substring bit-string start end)))
+
+;; Debugging assistance
+
+(define (verify-instruction instruction)
+ (let ((bits (car (lap:syntax-instruction instruction))))
+ (if (bit-string? bits)
+ (begin
+ (let ((disassembly (disassemble bits)))
+ (if (and (null? (cdr disassembly))
+ (equal? (car disassembly) instruction))
+ #T
+ disassembly)))
+ (error "Assember oddity" bits))))
+
+(define (v i) (verify-instruction i))
+\f
+;;;; The disassembler proper
+
+(define (handle-bad-instruction word)
+ word
+ (invalid-instruction))
+
+(define (disassemble bit-string)
+ (let ((stop (bit-string-length bit-string)))
+ (let loop ((from 0)
+ (to 32)
+ (result '()))
+ (if (> to stop)
+ result
+ (loop to (+ to 32) (cons (disassemble-word (bit-substring bit-string from to))
+ result))))))
+
+(define disassemblers (make-vector (expt 2 6) handle-bad-instruction))
+
+(define (disassemble-word word)
+ (let ((op-code (extract word 26 32)))
+ ((vector-ref disassemblers op-code) word)))
+
+(vector-set! disassemblers special-op
+ (lambda (word) (disassemble-special word)))
+(vector-set! disassemblers bcond-op
+ (lambda (word) (disassemble-branch-zero word)))
+(vector-set! disassemblers j-op
+ (lambda (word) (disassemble-jump word 'j)))
+(vector-set! disassemblers jal-op
+ (lambda (word) (disassemble-jump word 'jal)))
+(vector-set! disassemblers beq-op
+ (lambda (word) (disassemble-compare word 'beq)))
+(vector-set! disassemblers bne-op
+ (lambda (word) (disassemble-compare word 'bne)))
+(vector-set! disassemblers blez-op
+ (lambda (word) (disassemble-branch-zero-op word 'blez)))
+(vector-set! disassemblers bgtz-op
+ (lambda (word) (disassemble-branch-zero-op word 'bgtz)))
+(vector-set! disassemblers addi-op
+ (lambda (word) (disassemble-immediate word 'addi)))
+(vector-set! disassemblers addiu-op
+ (lambda (word) (disassemble-immediate word 'addiu)))
+(vector-set! disassemblers slti-op
+ (lambda (word) (disassemble-immediate word 'slti)))
+(vector-set! disassemblers sltiu-op
+ (lambda (word) (disassemble-immediate word 'sltiu)))
+(vector-set! disassemblers andi-op
+ (lambda (word) (disassemble-unsigned-immediate word 'andi)))
+(vector-set! disassemblers ori-op
+ (lambda (word) (disassemble-unsigned-immediate word 'ori)))
+(vector-set! disassemblers xori-op
+ (lambda (word) (disassemble-unsigned-immediate word 'xori)))
+(vector-set! disassemblers lui-op
+ (lambda (word) (disassemble-lui word)))
+(vector-set! disassemblers cop0-op
+ (lambda (word) (disassemble-coprocessor word 0)))
+(vector-set! disassemblers cop1-op
+ (lambda (word) (disassemble-coprocessor word 1)))
+(vector-set! disassemblers cop2-op
+ (lambda (word) (disassemble-coprocessor word 2)))
+(vector-set! disassemblers cop3-op
+ (lambda (word) (disassemble-coprocessor word 3)))
+(vector-set! disassemblers lb-op
+ (lambda (word) (disassemble-load/store word 'lb)))
+(vector-set! disassemblers lh-op
+ (lambda (word) (disassemble-load/store word 'lh)))
+(vector-set! disassemblers lwl-op
+ (lambda (word) (disassemble-load/store word 'lwl)))
+(vector-set! disassemblers lw-op
+ (lambda (word) (disassemble-load/store word 'lw)))
+(vector-set! disassemblers lbu-op
+ (lambda (word) (disassemble-load/store word 'lbu)))
+(vector-set! disassemblers lhu-op
+ (lambda (word) (disassemble-load/store word 'lhu)))
+(vector-set! disassemblers lwr-op
+ (lambda (word) (disassemble-load/store word 'lwr)))
+(vector-set! disassemblers sb-op
+ (lambda (word) (disassemble-load/store word 'sb)))
+(vector-set! disassemblers sh-op
+ (lambda (word) (disassemble-load/store word 'sh)))
+(vector-set! disassemblers swl-op
+ (lambda (word) (disassemble-load/store word 'swl)))
+(vector-set! disassemblers sw-op
+ (lambda (word) (disassemble-load/store word 'sw)))
+(vector-set! disassemblers swr-op
+ (lambda (word) (disassemble-load/store word 'swr)))
+(vector-set! disassemblers lwc0-op
+ (lambda (word) (disassemble-load/store word 'lwc0)))
+(vector-set! disassemblers lwc1-op
+ (lambda (word) (disassemble-load/store word 'lwc1)))
+(vector-set! disassemblers lwc2-op
+ (lambda (word) (disassemble-load/store word 'lwc2)))
+(vector-set! disassemblers lwc3-op
+ (lambda (word) (disassemble-load/store word 'lwc3)))
+(vector-set! disassemblers swc0-op
+ (lambda (word) (disassemble-load/store word 'swc0)))
+(vector-set! disassemblers swc1-op
+ (lambda (word) (disassemble-load/store word 'swc1)))
+(vector-set! disassemblers swc2-op
+ (lambda (word) (disassemble-load/store word 'swc2)))
+(vector-set! disassemblers swc3-op
+ (lambda (word) (disassemble-load/store word 'swc3)))
+
+(define special-disassemblers (make-vector (expt 2 6) handle-bad-instruction))
+
+(define (disassemble-special word)
+ (let ((function-code (extract word 0 6)))
+ ((vector-ref special-disassemblers function-code) word)))
+
+(vector-set! special-disassemblers sll-funct (lambda (word) (shift word 'sll)))
+(vector-set! special-disassemblers srl-funct (lambda (word) (shift word 'srl)))
+(vector-set! special-disassemblers sra-funct (lambda (word) (shift word 'sra)))
+(vector-set! special-disassemblers sllv-funct (lambda (word) (shift-variable word 'sllv)))
+(vector-set! special-disassemblers srlv-funct (lambda (word) (shift-variable word 'srlv)))
+(vector-set! special-disassemblers srav-funct (lambda (word) (shift-variable word 'srav)))
+(vector-set! special-disassemblers jr-funct
+ (lambda (word)
+ (let ((MBZ (extract word 6 21))
+ (rs (extract word 21 26)))
+ (if (zero? MBZ)
+ `(jr ,rs)
+ (invalid-instruction)))))
+(vector-set! special-disassemblers jalr-funct
+ (lambda (word)
+ (let ((MBZ1 (extract word 16 21))
+ (MBZ2 (extract word 6 11))
+ (rs (extract word 21 26))
+ (rd (extract word 11 16)))
+ (if (and (zero? MBZ1) (zero? MBZ2))
+ `(JALR ,rd ,rs)
+ (invalid-instruction)))))
+(vector-set! special-disassemblers syscall-funct
+ (lambda (word)
+ (let ((MBZ (extract word 6 26)))
+ (if (zero? MBZ)
+ '(SYSCALL)
+ (invalid-instruction)))))
+(vector-set! special-disassemblers break-funct (lambda (word) `(BREAK ,(extract word 6 26))))
+(vector-set! special-disassemblers mfhi-funct (lambda (word) (from-hi/lo word 'mfhi)))
+(vector-set! special-disassemblers mthi-funct (lambda (word) (to-hi/lo word 'mthi)))
+(vector-set! special-disassemblers mflo-funct (lambda (word) (from-hi/lo word 'mflo)))
+(vector-set! special-disassemblers mtlo-funct (lambda (word) (to-hi/lo word 'mtlo)))
+(vector-set! special-disassemblers mult-funct (lambda (word) (mul/div word 'mult)))
+(vector-set! special-disassemblers multu-funct (lambda (word) (mul/div word 'multu)))
+(vector-set! special-disassemblers div-funct (lambda (word) (mul/div word 'div)))
+(vector-set! special-disassemblers divu-funct (lambda (word) (mul/div word 'divu)))
+(vector-set! special-disassemblers add-funct (lambda (word) (arith word 'add)))
+(vector-set! special-disassemblers addu-funct (lambda (word) (arith word 'addu)))
+(vector-set! special-disassemblers sub-funct (lambda (word) (arith word 'sub)))
+(vector-set! special-disassemblers subu-funct (lambda (word) (arith word 'subu)))
+(vector-set! special-disassemblers and-funct (lambda (word) (arith word 'and)))
+(vector-set! special-disassemblers or-funct (lambda (word) (arith word 'or)))
+(vector-set! special-disassemblers xor-funct (lambda (word) (arith word 'xor)))
+(vector-set! special-disassemblers nor-funct (lambda (word) (arith word 'nor)))
+(vector-set! special-disassemblers slt-funct (lambda (word) (arith word 'slt)))
+(vector-set! special-disassemblers sltu-funct (lambda (word) (arith word 'sltu)))
+
+(define (shift word op)
+ (let ((MBZ (extract word 21 26))
+ (rt (extract word 16 21))
+ (rd (extract word 11 16))
+ (shamt (extract word 6 11)))
+ (if (zero? MBZ)
+ `(,op ,rd ,rt ,shamt)
+ (invalid-instruction))))
+
+(define (shift-variable word op)
+ (let ((MBZ (extract word 6 11))
+ (rs (extract word 21 26))
+ (rt (extract word 16 21))
+ (rd (extract word 11 16)))
+ (if (zero? MBZ)
+ `(,op ,rd ,rt ,rs)
+ (invalid-instruction))))
+
+(define (from-hi/lo word op)
+ (let ((MBZ1 (extract word 16 26))
+ (MBZ2 (extract word 6 11))
+ (rd (extract word 11 16)))
+ (if (and (zero? MBZ1) (zero? MBZ2))
+ `(,op ,rd)
+ (invalid-instruction))))
+
+(define (to-hi/lo word op)
+ (let ((MBZ (extract word 6 21))
+ (rs (extract word 21 26)))
+ (if (zero? MBZ)
+ `(,op ,rs)
+ (invalid-instruction))))
+
+(define (mul/div word op)
+ (let ((MBZ (extract word 6 16))
+ (rs (extract word 21 26))
+ (rt (extract word 16 21)))
+ (if (zero? MBZ)
+ `(,op ,rs ,rt)
+ (invalid-instruction))))
+
+(define (arith word op)
+ (let ((MBZ (extract word 6 11))
+ (rs (extract word 21 26))
+ (rt (extract word 16 21))
+ (rd (extract word 11 16)))
+ (if (zero? MBZ)
+ `(,op ,rd ,rs ,rt)
+ (invalid-instruction))))
+
+(define (disassemble-jump word op)
+ `(,op ,(extract word 0 26)))
+
+(define (relative-offset word)
+ `(@PCO ,(* 4 (extract-signed word 0 16))))
+
+(define (disassemble-branch-zero word)
+ (let ((conditions (extract word 16 21))
+ (rs (extract word 21 26))
+ (offset (relative-offset word)))
+ (cond ((= conditions bltz-cond) `(BLTZ ,rs ,offset))
+ ((= conditions bltzal-cond) `(BLTZAL ,rs ,offset))
+ ((= conditions bgez-cond) `(BGEZ ,rs ,offset))
+ ((= conditions bgezal-cond) `(BGEZAL ,rs ,offset))
+ (else (invalid-instruction)))))
+
+(define (disassemble-branch-zero-op word op)
+ (let ((MBZ (extract word 16 21))
+ (rs (extract word 21 26)))
+ (if (zero? MBZ)
+ `(,op ,rs ,(relative-offset word))
+ (invalid-instruction))))
+
+(define (disassemble-compare word op)
+ `(,op ,(extract word 21 26)
+ ,(extract word 16 21)
+ ,(relative-offset word)))
+
+(define (disassemble-immediate word op)
+ `(,op ,(extract word 16 21)
+ ,(extract word 21 26)
+ ,(extract-signed word 0 16)))
+
+(define (disassemble-unsigned-immediate word op)
+ `(,op ,(extract word 16 21)
+ ,(extract word 21 26)
+ ,(extract word 0 16)))
+
+(define (disassemble-lui word)
+ (if (zero? (extract word 21 26))
+ `(LUI ,(extract word 16 21)
+ ,(extract word 0 16))
+ (invalid-instruction)))
+
+(define (floating-point-cases code)
+ (let ((format (extract code 21 25))
+ (ft (extract code 16 21))
+ (fs (extract code 11 16))
+ (fd (extract code 6 11))
+ (fp-code (extract code 0 6)))
+ (let ((fmt (case format ((0) 'SINGLE) ((1) 'DOUBLE) (else '()))))
+ (define (two-arg op-name)
+ (if (zero? ft)
+ (list op-name fmt fd fs)
+ (invalid-instruction)))
+ (define (compare op-name)
+ (if (zero? fd)
+ (list op-name fmt fs ft)
+ (invalid-instruction)))
+ (if fmt
+ (cond
+ ((= fp-code addf-op) `(FADD ,fmt ,fd ,fs ,ft))
+ ((= fp-code subf-op) `(FSUB ,fmt ,fd ,fs ,ft))
+ ((= fp-code mulf-op) `(FMUL ,fmt ,fd ,fs ,ft))
+ ((= fp-code divf-op) `(FDIV ,fmt ,fd ,fs ,ft))
+ ((= fp-code absf-op) (two-arg 'FABS))
+ ((= fp-code movf-op) (two-arg 'FMOV))
+ ((= fp-code negf-op) (two-arg 'FNEG))
+ ((= fp-code cvt.sf-op) (two-arg 'CVT.S))
+ ((= fp-code cvt.df-op) (two-arg 'CVT.D))
+ ((= fp-code cvt.wf-op) (two-arg 'CVT.W))
+ ((= fp-code c.ff-op) (compare 'C.F))
+ ((= fp-code c.unf-op) (compare 'C.UN))
+ ((= fp-code c.eqf-op) (compare 'C.EQ))
+ ((= fp-code c.ueqf-op) (compare 'C.UEQ))
+ ((= fp-code c.oltf-op) (compare 'C.OLT))
+ ((= fp-code c.ultf-op) (compare 'C.ULT))
+ ((= fp-code c.olef-op) (compare 'C.OLE))
+ ((= fp-code c.ulef-op) (compare 'C.ULE))
+ ((= fp-code c.sff-op) (compare 'C.SF))
+ ((= fp-code c.nglef-op) (compare 'C.NGLE))
+ ((= fp-code c.seqf-op) (compare 'C.SEQ))
+ ((= fp-code c.nglf-op) (compare 'C.NGL))
+ ((= fp-code c.ltf-op) (compare 'C.LT))
+ ((= fp-code c.ngef-op) (compare 'C.NGE))
+ ((= fp-code c.lef-op) (compare 'C.LE))
+ ((= fp-code c.ngtf-op) (compare 'C.NGT))
+ (else (invalid-instruction)))
+ (invalid-instruction)))))
+
+(define (disassemble-coprocessor word op)
+ (define (simple-cases op2)
+ (if (zero? (extract word 0 11))
+ `(,op2 ,(extract word 16 21) ,(extract word 11 16))))
+ (define (branch-cases op2)
+ `(,op2 ,(relative-offset word)))
+ (define (cop0-cases code)
+ (case code
+ ((1) '(TLBR))
+ ((2) '(TLBWI))
+ ((6) '(TLBWR))
+ ((8) '(TLBP))
+ ((16) '(RFE))
+ (else `(COP0 ,code))))
+ (let ((code-high-bits (+ (* 4 (extract word 21 23))
+ (extract word 16 17)))
+ (code-low-bits (extract word 23 26)))
+ (let ((code (+ (* code-high-bits 8) code-low-bits)))
+ (case code
+ ((0 8) ; MF
+ (case op
+ ((0) (simple-cases 'mfc0))
+ ((1) (simple-cases 'mfc1))
+ ((2) (simple-cases 'mfc2))
+ ((3) (simple-cases 'mfc3))))
+ ((1 9) ; MT
+ (case op
+ ((0) (simple-cases 'mtc0))
+ ((1) (simple-cases 'mtc1))
+ ((2) (simple-cases 'mtc2))
+ ((3) (simple-cases 'mtc3))))
+ ((2 3) ; BCF
+ (case op
+ ((0) (branch-cases 'bcf0))
+ ((1) (branch-cases 'bcf1))
+ ((2) (branch-cases 'bcf2))
+ ((3) (branch-cases 'bcf3))))
+ ((4 5 6 7 12 13 14 15 20 21 22 23 28 29 30 31
+ 36 37 38 39 44 45 46 47 52 53 54 55 60 61 62 63) ; CO
+ (case op
+ ((0) (cop0-cases (extract word 0 25)))
+ ((1) (floating-point-cases (bit-substring word 0 25)))
+ ((2) `(cop2 ,(extract word 0 25)))
+ ((3) `(cop3 ,(extract word 0 25)))))
+ ((10 11) ; BCT
+ (case op
+ ((0) (branch-cases 'bct0))
+ ((1) (branch-cases 'bct1))
+ ((2) (branch-cases 'bct2))
+ ((3) (branch-cases 'bct3))))
+ ((32 40) ; CF
+ (case op
+ ((0) (simple-cases 'cfc0))
+ ((1) (simple-cases 'cfc1))
+ ((3) (simple-cases 'cfc2))
+ ((3) (simple-cases 'cfc3))))
+ ((33 41) ; CT
+ (case op
+ ((0) (simple-cases 'ctc0))
+ ((1) (simple-cases 'ctc1))
+ ((2) (simple-cases 'ctc2))
+ ((3) (simple-cases 'ctc3))))
+ (else (invalid-instruction))))))
+
+(define (disassemble-load/store word op)
+ `(,op ,(extract word 16 21)
+ (OFFSET ,(extract-signed word 0 16) ,(extract word 21 26))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/decls.scm,v 1.1 1990/05/07 04:12:47 jinx Exp $
+$MC68020-Header: decls.scm,v 4.25 90/01/18 22:43:31 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler File Dependencies
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (add-event-receiver! event:after-restore reset-source-nodes!)
+ (reset-source-nodes!))
+
+(define (reset-source-nodes!)
+ (set! source-filenames '())
+ (set! source-hash)
+ (set! source-nodes)
+ (set! source-nodes/by-rank))
+
+(define (maybe-setup-source-nodes!)
+ (if (null? source-filenames)
+ (setup-source-nodes!)))
+
+(define (setup-source-nodes!)
+ (let ((filenames
+ (mapcan (lambda (subdirectory)
+ (map (lambda (pathname)
+ (string-append subdirectory
+ "/"
+ (pathname-name pathname)))
+ (directory-read
+ (string-append subdirectory
+ "/"
+ source-file-expression))))
+ '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
+ "machines/mips"))))
+ (if (null? filenames)
+ (error "Can't find source files of compiler"))
+ (set! source-filenames filenames))
+ (set! source-hash
+ (make/hash-table
+ 101
+ string-hash-mod
+ (lambda (filename source-node)
+ (string=? filename (source-node/filename source-node)))
+ make/source-node))
+ (set! source-nodes
+ (map (lambda (filename)
+ (hash-table/intern! source-hash
+ filename
+ identity-procedure
+ identity-procedure))
+ source-filenames))
+ (initialize/syntax-dependencies!)
+ (initialize/integration-dependencies!)
+ (initialize/expansion-dependencies!)
+ (source-nodes/rank!))
+
+(define source-file-expression "*.scm")
+(define source-filenames)
+(define source-hash)
+(define source-nodes)
+(define source-nodes/by-rank)
+
+(define (filename/append directory . names)
+ (map (lambda (name) (string-append directory "/" name)) names))
+\f
+(define-structure (source-node
+ (conc-name source-node/)
+ (constructor make/source-node (filename)))
+ (filename false read-only true)
+ (pathname (string->pathname filename) read-only true)
+ (forward-links '())
+ (backward-links '())
+ (forward-closure '())
+ (backward-closure '())
+ (dependencies '())
+ (dependents '())
+ (rank false)
+ (syntax-table false)
+ (declarations '())
+ (modification-time false))
+
+(define (filename->source-node filename)
+ (hash-table/lookup source-hash
+ filename
+ identity-procedure
+ (lambda () (error "Unknown source file" filename))))
+
+(define (source-node/circular? node)
+ (memq node (source-node/backward-closure node)))
+
+(define (source-node/link! node dependency)
+ (if (not (memq dependency (source-node/backward-links node)))
+ (begin
+ (set-source-node/backward-links!
+ node
+ (cons dependency (source-node/backward-links node)))
+ (set-source-node/forward-links!
+ dependency
+ (cons node (source-node/forward-links dependency)))
+ (source-node/close! node dependency))))
+
+(define (source-node/close! node dependency)
+ (if (not (memq dependency (source-node/backward-closure node)))
+ (begin
+ (set-source-node/backward-closure!
+ node
+ (cons dependency (source-node/backward-closure node)))
+ (set-source-node/forward-closure!
+ dependency
+ (cons node (source-node/forward-closure dependency)))
+ (for-each (lambda (dependency)
+ (source-node/close! node dependency))
+ (source-node/backward-closure dependency))
+ (for-each (lambda (node)
+ (source-node/close! node dependency))
+ (source-node/forward-closure node)))))
+\f
+;;;; Rank
+
+(define (source-nodes/rank!)
+ (compute-dependencies! source-nodes)
+ (compute-ranks! source-nodes)
+ (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes)))
+
+(define (compute-dependencies! nodes)
+ (for-each (lambda (node)
+ (set-source-node/dependencies!
+ node
+ (list-transform-negative (source-node/backward-closure node)
+ (lambda (node*)
+ (memq node (source-node/backward-closure node*)))))
+ (set-source-node/dependents!
+ node
+ (list-transform-negative (source-node/forward-closure node)
+ (lambda (node*)
+ (memq node (source-node/forward-closure node*))))))
+ nodes))
+
+(define (compute-ranks! nodes)
+ (let loop ((nodes nodes) (unranked-nodes '()))
+ (if (null? nodes)
+ (if (not (null? unranked-nodes))
+ (loop unranked-nodes '()))
+ (loop (cdr nodes)
+ (let ((node (car nodes)))
+ (let ((rank (source-node/rank* node)))
+ (if rank
+ (begin
+ (set-source-node/rank! node rank)
+ unranked-nodes)
+ (cons node unranked-nodes))))))))
+
+(define (source-node/rank* node)
+ (let loop ((nodes (source-node/dependencies node)) (rank -1))
+ (if (null? nodes)
+ (1+ rank)
+ (let ((rank* (source-node/rank (car nodes))))
+ (and rank*
+ (loop (cdr nodes) (max rank rank*)))))))
+
+(define (source-nodes/sort-by-rank nodes)
+ (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
+\f
+;;;; File Syntaxer
+
+(define (syntax-files!)
+ (maybe-setup-source-nodes!)
+ (for-each
+ (lambda (node)
+ (let ((modification-time
+ (let ((source (modification-time node "scm"))
+ (binary (modification-time node "bin")))
+ (if (not source)
+ (error "Missing source file" (source-node/filename node)))
+ (and binary (< source binary) binary))))
+ (set-source-node/modification-time! node modification-time)
+ (if (not modification-time)
+ (begin (write-string "\nSource file newer than binary: ")
+ (write (source-node/filename node))))))
+ source-nodes)
+ (if compiler:enable-integration-declarations?
+ (begin
+ (for-each
+ (lambda (node)
+ (let ((time (source-node/modification-time node)))
+ (if (and time
+ (there-exists? (source-node/dependencies node)
+ (lambda (node*)
+ (let ((newer?
+ (let ((time*
+ (source-node/modification-time node*)))
+ (or (not time*)
+ (> time* time)))))
+ (if newer?
+ (begin
+ (write-string "\nBinary file ")
+ (write (source-node/filename node))
+ (write-string " newer than dependency ")
+ (write (source-node/filename node*))))
+ newer?))))
+ (set-source-node/modification-time! node false))))
+ source-nodes)
+ (for-each
+ (lambda (node)
+ (if (not (source-node/modification-time node))
+ (for-each (lambda (node*)
+ (if (source-node/modification-time node*)
+ (begin
+ (write-string "\nBinary file ")
+ (write (source-node/filename node*))
+ (write-string " depends on ")
+ (write (source-node/filename node))))
+ (set-source-node/modification-time! node* false))
+ (source-node/forward-closure node))))
+ source-nodes)))
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (pathname-delete!
+ (pathname-new-type (source-node/pathname node) "ext"))))
+ source-nodes/by-rank)
+ (write-string "\n\nBegin pass 1:")
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (source-node/syntax! node)))
+ source-nodes/by-rank)
+ (if (there-exists? source-nodes/by-rank
+ (lambda (node)
+ (and (not (source-node/modification-time node))
+ (source-node/circular? node))))
+ (begin
+ (write-string "\n\nBegin pass 2:")
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (if (source-node/circular? node)
+ (source-node/syntax! node)
+ (source-node/touch! node))))
+ source-nodes/by-rank))))
+\f
+(define (source-node/touch! node)
+ (with-values
+ (lambda ()
+ (sf/pathname-defaulting (source-node/pathname node) "" false))
+ (lambda (input-pathname bin-pathname spec-pathname)
+ input-pathname
+ (pathname-touch! bin-pathname)
+ (pathname-touch! (pathname-new-type bin-pathname "ext"))
+ (if spec-pathname (pathname-touch! spec-pathname)))))
+
+(define (pathname-touch! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-string "\nTouch file: ")
+ (write (pathname->string pathname))
+ (file-touch pathname))))
+
+(define (pathname-delete! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-string "\nDelete file: ")
+ (write (pathname->string pathname))
+ (delete-file pathname))))
+
+(define (sc filename)
+ (maybe-setup-source-nodes!)
+ (source-node/syntax! (filename->source-node filename)))
+
+(define (source-node/syntax! node)
+ (with-values
+ (lambda ()
+ (sf/pathname-defaulting (source-node/pathname node) "" false))
+ (lambda (input-pathname bin-pathname spec-pathname)
+ (sf/internal
+ input-pathname bin-pathname spec-pathname
+ (source-node/syntax-table node)
+ ((if compiler:enable-integration-declarations?
+ identity-procedure
+ (lambda (declarations)
+ (list-transform-negative declarations
+ integration-declaration?)))
+ ((if compiler:enable-expansion-declarations?
+ identity-procedure
+ (lambda (declarations)
+ (list-transform-negative declarations
+ expansion-declaration?)))
+ (source-node/declarations node)))))))
+
+(define-integrable (modification-time node type)
+ (file-modification-time
+ (pathname-new-type (source-node/pathname node) type)))
+\f
+;;;; Syntax dependencies
+
+(define (initialize/syntax-dependencies!)
+ (let ((file-dependency/syntax/join
+ (lambda (filenames syntax-table)
+ (for-each (lambda (filename)
+ (set-source-node/syntax-table!
+ (filename->source-node filename)
+ syntax-table))
+ filenames))))
+ (file-dependency/syntax/join
+ (append (filename/append "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "constr"
+ "contin" "crstop" "ctypes" "debug" "enumer"
+ "infnew" "lvalue" "object" "pmerly" "proced"
+ "refctx" "rvalue" "scode" "sets" "subprb"
+ "switch" "toplev" "utils")
+ (filename/append "back"
+ "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
+ "lapgn2" "lapgn3" "linear" "regmap" "symtab"
+ "syntax")
+ (filename/append "machines/mips"
+ "dassm1" "insmac" "machin" "rgspcm"
+ "rulrew")
+ (filename/append "fggen"
+ "declar" "fggen" "canon")
+ (filename/append "fgopt"
+ "blktyp" "closan" "conect" "contan" "delint"
+ "desenv" "envopt" "folcon" "offset" "operan"
+ "order" "outer" "param" "reord" "reteqv" "reuse"
+ "sideff" "simapp" "simple" "subfre" "varind")
+ (filename/append "rtlbase"
+ "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
+ "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
+ "valclass")
+ (filename/append "rtlgen"
+ "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
+ "rgretn" "rgrval" "rgstmt" "rtlgen")
+ (filename/append "rtlopt"
+ "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
+ "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
+ "rerite" "rinvex" "rlife" "rtlcsm"))
+ compiler-syntax-table)
+ (file-dependency/syntax/join
+ (filename/append "machines/mips"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
+ )
+ lap-generator-syntax-table)
+ (file-dependency/syntax/join
+ (filename/append "machines/mips" "instr1" "instr2a" "instr2b" "instr3")
+ assembler-syntax-table)))
+\f
+;;;; Integration Dependencies
+
+(define (initialize/integration-dependencies!)
+
+ (define (add-declaration! declaration filenames)
+ (for-each (lambda (filenames)
+ (let ((node (filename->source-node filenames)))
+ (set-source-node/declarations!
+ node
+ (cons declaration
+ (source-node/declarations node)))))
+ filenames))
+
+ (let ((front-end-base
+ (filename/append "base"
+ "blocks" "cfg1" "cfg2" "cfg3"
+ "contin" "ctypes" "enumer" "lvalue"
+ "object" "proced" "rvalue"
+ "scode" "subprb" "utils"))
+ (mips-base
+ (filename/append "machines/mips" "machin"))
+ (rtl-base
+ (filename/append "rtlbase"
+ "regset" "rgraph" "rtlcfg" "rtlobj"
+ "rtlreg" "rtlty1" "rtlty2"))
+ (cse-base
+ (filename/append "rtlopt"
+ "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr"))
+ (instruction-base
+ (filename/append "machines/mips" "assmd" "machin"))
+ (lapgen-base
+ (append (filename/append "back" "lapgn3" "regmap")
+ (filename/append "machines/mips" "lapgen")))
+ (assembler-base
+ (append (filename/append "back" "symtab")
+ (filename/append "machines/mips"
+ "instr1" "instr2a" "instr2b" "instr3")))
+ (lapgen-body
+ (append
+ (filename/append "back" "lapgn1" "lapgn2" "syntax")
+ (filename/append "machines/mips"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo"
+ )))
+ (assembler-body
+ (append
+ (filename/append "back" "bittop")
+ (filename/append "machines/mips"
+ "instr1" "instr2a" "instr2b" "instr3"))))
+
+ (define (file-dependency/integration/join filenames dependencies)
+ (for-each (lambda (filename)
+ (file-dependency/integration/make filename dependencies))
+ filenames))
+
+ (define (file-dependency/integration/make filename dependencies)
+ (let ((node (filename->source-node filename)))
+ (for-each (lambda (dependency)
+ (let ((node* (filename->source-node dependency)))
+ (if (not (eq? node node*))
+ (source-node/link! node node*))))
+ dependencies)))
+
+ (define (define-integration-dependencies directory name directory* . names)
+ (file-dependency/integration/make
+ (string-append directory "/" name)
+ (apply filename/append directory* names)))
+
+ (define-integration-dependencies "base" "object" "base" "enumer")
+ (define-integration-dependencies "base" "enumer" "base" "object")
+ (define-integration-dependencies "base" "utils" "base" "scode")
+ (define-integration-dependencies "base" "cfg1" "base" "object")
+ (define-integration-dependencies "base" "cfg2" "base"
+ "cfg1" "cfg3" "object")
+ (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "base" "ctypes" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
+ (define-integration-dependencies "base" "rvalue" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
+ (define-integration-dependencies "base" "lvalue" "base"
+ "blocks" "object" "proced" "rvalue" "utils")
+ (define-integration-dependencies "base" "blocks" "base"
+ "enumer" "lvalue" "object" "proced" "rvalue" "scode")
+ (define-integration-dependencies "base" "proced" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
+ "rvalue" "utils")
+ (define-integration-dependencies "base" "contin" "base"
+ "blocks" "cfg3" "ctypes")
+ (define-integration-dependencies "base" "subprb" "base"
+ "cfg3" "contin" "enumer" "object" "proced")
+
+ (define-integration-dependencies "machines/mips" "machin" "rtlbase"
+ "rtlreg" "rtlty1" "rtlty2")
+ (define-integration-dependencies "machines/mips" "instr1" "machines/mips"
+ "instr2a" "instr2b" "instr3")
+
+ (define-integration-dependencies "rtlbase" "regset" "base")
+ (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rgraph" "machines/mips"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlcfg" "base"
+ "cfg1" "cfg2" "cfg3")
+ (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
+ (define-integration-dependencies "rtlbase" "rtlcon" "machines/mips"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
+ "rtlreg" "rtlty1")
+ (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
+ "rtlcfg" "rtlty2")
+ (define-integration-dependencies "rtlbase" "rtlobj" "base"
+ "cfg1" "object" "utils")
+ (define-integration-dependencies "rtlbase" "rtlreg" "machines/mips"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
+ "rgraph" "rtlty1")
+ (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode")
+ (define-integration-dependencies "rtlbase" "rtlty2" "machines/mips"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
+
+ (file-dependency/integration/join
+ (append
+ (filename/append "base" "refctx")
+ (filename/append "fggen"
+ "declar" "fggen") ; "canon" needs no integrations
+ (filename/append "fgopt"
+ "blktyp" "closan" "conect" "contan" "delint" "desenv"
+ "envopt" "folcon" "offset" "operan" "order" "param"
+ "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
+ "subfre" "varind"))
+ (append mips-base front-end-base))
+
+ (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
+
+ (file-dependency/integration/join
+ (filename/append "rtlgen"
+ "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
+ "rgrval" "rgstmt" "rtlgen")
+ (append mips-base front-end-base rtl-base))
+
+ (file-dependency/integration/join
+ (append cse-base
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
+ "rerite" "rinvex" "rlife" "rtlcsm")
+ (filename/append "machines/mips" "rulrew")
+ )
+ (append mips-base rtl-base))
+
+ (file-dependency/integration/join cse-base cse-base)
+
+ (define-integration-dependencies "rtlopt" "rcseht" "base" "object")
+ (define-integration-dependencies "rtlopt" "rcserq" "base" "object")
+ (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
+
+ (let ((dependents
+ (append instruction-base
+ lapgen-base
+ lapgen-body
+ assembler-base
+ assembler-body
+ (filename/append "back" "linear" "syerly"))))
+ (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
+ (file-dependency/integration/join dependents instruction-base))
+
+ (file-dependency/integration/join (append lapgen-base lapgen-body)
+ lapgen-base)
+
+ (file-dependency/integration/join (append assembler-base assembler-body)
+ assembler-base)
+
+ (define-integration-dependencies "back" "lapgn1" "base"
+ "cfg1" "cfg2" "utils")
+ (define-integration-dependencies "back" "lapgn1" "rtlbase"
+ "regset" "rgraph" "rtlcfg")
+ (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
+ (define-integration-dependencies "back" "lapgn3" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "back" "mermap" "back" "regmap")
+ (define-integration-dependencies "back" "regmap" "base" "utils")
+ (define-integration-dependencies "back" "symtab" "base" "utils"))
+
+ (for-each (lambda (node)
+ (let ((links (source-node/backward-links node)))
+ (if (not (null? links))
+ (set-source-node/declarations!
+ node
+ (cons (make-integration-declaration
+ (source-node/pathname node)
+ (map source-node/pathname links))
+ (source-node/declarations node))))))
+ source-nodes))
+
+(define (make-integration-declaration pathname integration-dependencies)
+ `(INTEGRATE-EXTERNAL
+ ,@(map (let ((default
+ (make-pathname
+ false
+ false
+ (make-list (length (pathname-directory pathname)) 'UP)
+ false
+ false
+ false)))
+ (lambda (pathname)
+ (merge-pathnames pathname default)))
+ integration-dependencies)))
+
+(define-integrable (integration-declaration? declaration)
+ (eq? (car declaration) 'INTEGRATE-EXTERNAL))
+\f
+;;;; Expansion Dependencies
+
+(define (initialize/expansion-dependencies!)
+ (let ((file-dependency/expansion/join
+ (lambda (filenames expansions)
+ (for-each (lambda (filename)
+ (let ((node (filename->source-node filename)))
+ (set-source-node/declarations!
+ node
+ (cons (make-expansion-declaration expansions)
+ (source-node/declarations node)))))
+ filenames))))
+ (file-dependency/expansion/join
+ (filename/append "machines/mips"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo"
+ )
+ (map (lambda (entry)
+ `(,(car entry)
+ (PACKAGE/REFERENCE
+ (FIND-PACKAGE '(COMPILER LAP-SYNTAXER)) ',(cadr entry))))
+ '((LAP:SYNTAX-INSTRUCTION LAP:SYNTAX-INSTRUCTION-EXPANDER)
+ (INSTRUCTION->INSTRUCTION-SEQUENCE
+ INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER)
+ (SYNTAX-EVALUATION SYNTAX-EVALUATION-EXPANDER)
+ (CONS-SYNTAX CONS-SYNTAX-EXPANDER)
+ (OPTIMIZE-GROUP-EARLY OPTIMIZE-GROUP-EXPANDER)
+ (EA-KEYWORD-EARLY EA-KEYWORD-EXPANDER)
+ (EA-MODE-EARLY EA-MODE-EXPANDER)
+ (EA-REGISTER-EARLY EA-REGISTER-EXPANDER)
+ (EA-EXTENSION-EARLY EA-EXTENSION-EXPANDER)
+ (EA-CATEGORIES-EARLY EA-CATEGORIES-EXPANDER))))))
+
+(define-integrable (make-expansion-declaration expansions)
+ `(EXPAND-OPERATOR ,@expansions))
+
+(define-integrable (expansion-declaration? declaration)
+ (eq? (car declaration) 'EXPAND-OPERATOR))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/inerly.scm,v 1.1 1990/05/07 04:13:26 jinx Rel $
+$MC68020-Header: inerly.scm,v 1.6 88/08/31 06:00:59 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 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. |#
+
+;;; MIPS Instruction Set Macros. Early version
+;;; NOPs for now.
+
+(declare (usual-integrations))
+\f
+;;;; Transformers and utilities
+
+(define early-instructions '())
+(define early-transformers '())
+
+(define (define-early-transformer name transformer)
+ (set! early-transformers
+ (cons (cons name transformer)
+ early-transformers)))
+
+(define (eq-subset? s1 s2)
+ (or (null? s1)
+ (and (memq (car s1) s2)
+ (eq-subset? (cdr s1) s2))))
+
+;;; Instruction and addressing mode macros
+
+(syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION
+ (macro (opcode . patterns)
+ `(SET! EARLY-INSTRUCTIONS
+ (CONS
+ (LIST ',opcode
+ ,@(map (lambda (pattern)
+ `(early-parse-rule
+ ',(car pattern)
+ (lambda (pat vars)
+ (early-make-rule
+ pat
+ vars
+ (scode-quote
+ (instruction->instruction-sequence
+ ,(parse-instruction (cadr pattern)
+ (cddr pattern)
+ true)))))))
+ patterns))
+ EARLY-INSTRUCTIONS))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/insmac.scm,v 1.1 1990/05/07 04:13:45 jinx Rel $
+
+Copyright (c) 1988, 1989, 1990 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. |#
+
+;;;; MIPS Instruction Set Macros
+
+(declare (usual-integrations))
+\f
+;;;; Definition macros
+
+(syntax-table-define assembler-syntax-table 'DEFINE-SYMBOL-TRANSFORMER
+ (macro (name . alist)
+ `(begin
+ (declare (integrate-operator ,name))
+ (define (,name symbol)
+ (declare (integrate symbol))
+ (let ((place (assq symbol ',alist)))
+ (if (null? place)
+ #F
+ (cdr place)))))))
+
+(syntax-table-define assembler-syntax-table 'DEFINE-TRANSFORMER
+ (macro (name value)
+ `(define ,name ,value)))
+\f
+;;;; Fixed width instruction parsing
+
+(define (parse-instruction first-word tail early?)
+ (cond ((not (null? tail))
+ (error "parse-instruction: Unknown format" (cons first-word tail)))
+ ((eq? (car first-word) 'LONG)
+ (process-fields (cdr first-word) early?))
+ ((eq? (car first-word) 'VARIABLE-WIDTH)
+ (process-variable-width first-word early?))
+ (else
+ (error "parse-instruction: Unknown format" first-word))))
+
+(define (process-variable-width descriptor early?)
+ (let ((binding (cadr descriptor))
+ (clauses (cddr descriptor)))
+ `(LIST
+ ,(variable-width-expression-syntaxer
+ (car binding) ; name
+ (cadr binding) ; expression
+ (map (lambda (clause)
+ (expand-fields
+ (cdadr clause)
+ early?
+ (lambda (code size)
+ (if (not (zero? (remainder size 32)))
+ (error "process-variable-width: bad clause size" size))
+ `((LIST ,(optimize-group-syntax code early?))
+ ,size
+ ,@(car clause)))))
+ clauses)))))
+
+(define (process-fields fields early?)
+ (expand-fields fields
+ early?
+ (lambda (code size)
+ (if (not (zero? (remainder size 32)))
+ (error "process-fields: bad syllable size" size))
+ `(LIST ,(optimize-group-syntax code early?)))))
+
+(define (expand-fields fields early? receiver)
+ (define (expand first-word word-size fields receiver)
+ (if (null? fields)
+ (receiver '() 0)
+ (expand-field
+ (car fields) early?
+ (lambda (car-field car-size)
+ (if (and (eq? endianness 'LITTLE)
+ (= 32 (+ word-size car-size)))
+ (expand '() 0 (cdr fields)
+ (lambda (tail tail-size)
+ (receiver
+ (append (cons car-field first-word) tail)
+ (+ car-size tail-size))))
+ (expand (cons car-field first-word)
+ (+ car-size word-size)
+ (cdr fields)
+ (lambda (tail tail-size)
+ (receiver
+ (if (or (zero? car-size)
+ (not (eq? endianness 'LITTLE)))
+ (cons car-field tail)
+ tail)
+ (+ car-size tail-size)))))))))
+ (expand '() 0 fields receiver))
+
+(define (expand-field field early? receiver)
+ early? ; ignored for now
+ (let ((size (car field))
+ (expression (cadr field)))
+
+ (define (default type)
+ (receiver (integer-syntaxer expression type size)
+ size))
+
+ (if (null? (cddr field))
+ (default 'UNSIGNED)
+ (case (caddr field)
+ ((PC-REL)
+ (receiver
+ (integer-syntaxer ``(- ,,expression (+ *PC* 4))
+ (cadddr field)
+ size)
+ size))
+ ((BLOCK-OFFSET)
+ (receiver (list 'list ''BLOCK-OFFSET expression)
+ size))
+ (else
+ (default (caddr field)))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr1.scm,v 1.1 1990/05/07 04:13:59 jinx Rel $
+
+Copyright (c) 1987, 1989, 1990 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. |#
+
+;;;; MIPS instruction set
+
+(declare (usual-integrations))
+\f
+(define-integrable (extract bit-string start end)
+ (bit-string->unsigned-integer (bit-substring bit-string start end)))
+
+(define-integrable (extract-signed bit-string start end)
+ (bit-string->signed-integer (bit-substring bit-string start end)))
+
+(let-syntax
+ ((immediate-instruction
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? dest-reg-ii) (? source-reg-ii) (? immediate))
+ (LONG (6 ,opcode)
+ (5 source-reg-ii)
+ (5 dest-reg-ii)
+ (16 immediate SIGNED))))))
+ (unsigned-immediate-instruction
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? dest-reg-uii) (? source-reg-uii) (? uimmediate))
+ (LONG (6 ,opcode)
+ (5 source-reg-uii)
+ (5 dest-reg-uii)
+ (16 uimmediate))))))
+
+ (special-instruction
+ (macro (keyword special-op)
+ `(define-instruction ,keyword
+ (((? dest-sp) (? reg-1-sp) (? reg-2-sp))
+ (LONG (6 0)
+ (5 reg-1-sp)
+ (5 reg-2-sp)
+ (5 dest-sp)
+ (5 0)
+ (6 ,special-op))))))
+ (move-coprocessor-instruction
+ (macro (keyword opcode move-op)
+ `(define-instruction ,keyword
+ (((? rt-mci) (? rd-mci))
+ (LONG (6 ,opcode)
+ (5 ,move-op)
+ (5 rt-mci)
+ (5 rd-mci)
+ (11 0))))))
+ (coprocessor-instruction
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? cofun))
+ (LONG (6 ,opcode)
+ (1 1) ; CO bit
+ (25 cofun))))))
+ (div/mul-instruction
+ (macro (keyword funct)
+ `(define-instruction ,keyword
+ (((? rs-dm) (? rt-dm))
+ (LONG (6 0)
+ (5 rs-dm)
+ (5 rt-dm)
+ (10 0)
+ (6 ,funct))))))
+ (jump-instruction
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? dest-j))
+ (LONG (6 ,opcode)
+ (26 dest-j))))))
+
+ (from-hi/lo-instruction
+ (macro (keyword funct)
+ `(define-instruction ,keyword
+ (((? rd-fhl))
+ (LONG (6 0)
+ (10 0)
+ (5 rd-fhl)
+ (5 0)
+ (6 ,funct))))))
+ (to-hi/lo-instruction
+ (macro (keyword funct)
+ `(define-instruction ,keyword
+ (((? rd-thl))
+ (LONG (6 0)
+ (5 rd-thl)
+ (15 0)
+ (6 ,funct))))))
+ (cop0-instruction
+ (macro (keyword cp0-op)
+ `(define-instruction ,keyword
+ (()
+ (LONG (6 16)
+ (1 1) ; CO
+ (20 0)
+ (5 ,cp0-op))))))
+ (shift-instruction
+ (macro (keyword funct)
+ `(define-instruction ,keyword
+ (((? dest-sh) (? source-sh) (? amount))
+ (LONG (6 0)
+ (5 0)
+ (5 source-sh)
+ (5 dest-sh)
+ (5 amount)
+ (6 ,funct))))))
+ (shift-variable-instruction
+ (macro (keyword funct)
+ `(define-instruction ,keyword
+ (((? dest-sv) (? source-sv) (? amount-reg))
+ (LONG (6 0)
+ (5 amount-reg)
+ (5 source-sv)
+ (5 dest-sv)
+ (5 0)
+ (6 ,funct)))))))
+ (special-instruction add 32)
+ (immediate-instruction addi 8)
+ (immediate-instruction addiu 9)
+ (special-instruction addu 33)
+ (special-instruction and 36)
+ (unsigned-immediate-instruction andi 12)
+ (define-instruction break
+ (((? code))
+ (LONG (6 0) (20 code) (6 13))))
+ (move-coprocessor-instruction cfc0 16 #x002)
+ (move-coprocessor-instruction cfc1 17 #x002)
+ (move-coprocessor-instruction cfc2 18 #x002)
+ (move-coprocessor-instruction cfc3 19 #x002)
+ (coprocessor-instruction cop0 16)
+ (coprocessor-instruction cop1 17)
+ (coprocessor-instruction cop2 18)
+ (coprocessor-instruction cop3 19)
+ (move-coprocessor-instruction ctc0 16 #x006)
+ (move-coprocessor-instruction ctc1 17 #x006)
+ (move-coprocessor-instruction ctc2 18 #x006)
+ (move-coprocessor-instruction ctc3 19 #x006)
+ (div/mul-instruction div 26)
+ (div/mul-instruction divu 27)
+ (jump-instruction j 2)
+ (jump-instruction jal 3)
+ (define-instruction jalr
+ (((? rd-jalr) (? rs-jalr))
+ (LONG (6 0) (5 rs-jalr) (5 0) (5 rd-jalr) (5 0) (6 9))))
+ (define-instruction jr
+ (((? rs-jr))
+ (LONG (6 0) (5 rs-jr) (15 0) (6 8))))
+ (define-instruction lui
+ (((? dest-lui) (? immediate-lui))
+ (LONG (6 15) (5 0) (5 dest-lui) (16 immediate-lui))))
+ (move-coprocessor-instruction mfc0 16 #x000)
+ (move-coprocessor-instruction mfc1 17 #x000)
+ (move-coprocessor-instruction mfc2 18 #x000)
+ (move-coprocessor-instruction mfc3 19 #x000)
+ (from-hi/lo-instruction mfhi 16)
+ (from-hi/lo-instruction mflo 18)
+ (move-coprocessor-instruction mtc0 16 #x004)
+ (move-coprocessor-instruction mtc1 17 #x004)
+ (move-coprocessor-instruction mtc2 18 #x004)
+ (move-coprocessor-instruction mtc3 19 #x004)
+ (to-hi/lo-instruction mthi 17)
+ (to-hi/lo-instruction mtlo 19)
+ (div/mul-instruction mult 24)
+ (div/mul-instruction multu 25)
+ (special-instruction nor 39)
+ (special-instruction or 37)
+ (unsigned-immediate-instruction ori 13)
+ (cop0-instruction rfe 16)
+ (shift-instruction sll 0)
+ (shift-variable-instruction sllv 4)
+ (special-instruction slt 42)
+ (immediate-instruction slti 10)
+ (immediate-instruction sltiu 11)
+ (special-instruction sltu 43)
+ (shift-instruction sra 3)
+ (shift-variable-instruction srav 7)
+ (shift-instruction srl 2)
+ (shift-variable-instruction srlv 6)
+ (special-instruction sub 34)
+ (special-instruction subu 35)
+ (define-instruction syscall
+ (()
+ (LONG (6 0) (20 0) (6 12))))
+ (cop0-instruction tlbp 8)
+ (cop0-instruction tlbr 1)
+ (cop0-instruction tlbwi 2)
+ (cop0-instruction tlbwr 6)
+ (special-instruction xor 38)
+ (unsigned-immediate-instruction xori 14))
+
+;;;; Assembler pseudo-ops
+
+(define-instruction WORD
+ (((? expression))
+ (LONG (32 expression SIGNED))))
+
+(define-instruction UWORD
+ (((? expression))
+ (LONG (32 expression UNSIGNED))))
+
+; External labels cause the output of GC header and format words
+(define-instruction EXTERNAL-LABEL
+ (((? format-word) (@PCR (? label)))
+ (LONG (16 label BLOCK-OFFSET)
+ (16 format-word UNSIGNED)))
+
+ (((? format-word) (@PCO (? offset)))
+ (LONG (16 offset UNSIGNED)
+ (16 format-word UNSIGNED))))
+
+(define-instruction PC-RELATIVE-OFFSET
+ (((? target) (@PCR (? label)))
+ (VARIABLE-WIDTH (offset `(- ,label (+ *PC* 8)))
+ ((#x-8000 #x7FFF)
+ ; BGEZAL 0 X *PC* is here
+ ; ADDI target, 31, offset
+ ; X: ...
+ (LONG (6 1) ; BGEZAL
+ (5 0)
+ (5 17)
+ (16 1)
+ (6 8) ; ADDI
+ (5 31)
+ (5 target)
+ (16 offset SIGNED)))
+ ((() ())
+ ; BGEZAL 0 X *PC* is here
+ ; ADDIU target, 31, (right of offset)
+ ; X: LUI 1, (left_adjust of offset)
+ ; ADD target, target, 1
+ (LONG (6 1) ; BGEZAL
+ (5 0)
+ (5 17)
+ (16 1)
+ (6 9) ; ADDIU
+ (5 31)
+ (5 target)
+ (16 (adjusted:low offset) SIGNED)
+ (6 15) ; LUI
+ (5 0)
+ (5 1)
+ (16 (adjusted:high offset))
+ (6 0) ; ADD
+ (5 1)
+ (5 target)
+ (5 target)
+ (5 0)
+ (6 32)))))
+ (((? target) (? offset) (? label))
+ ; Load (into target) distance from here+offset to label
+ (VARIABLE-WIDTH (offset `(- ,label (+ ,offset *PC*)))
+ ((#x-8000 #x7FFF)
+ ; ADDI target, 0, offset
+ (LONG (6 8) ; ADDI
+ (5 0)
+ (5 target)
+ (16 offset SIGNED)))
+ ((#x8000 #xFFFF)
+ ; ORI target, 0, offset
+ (LONG (6 13) ; ORI
+ (5 0)
+ (5 target)
+ (16 offset)))
+ ((() ())
+ ; LUI target, (left_adjust of offset)
+ ; ADDIU target, target, (right of offset)
+ (LONG (6 15) ; LUI
+ (5 0)
+ (5 target)
+ (16 (adjusted:high offset))
+ (6 9) ; ADDIU
+ (5 target)
+ (5 target)
+ (16 (adjusted:low offset) SIGNED))))))
+
+(define-instruction NOP
+ (() ; ADDI 0, 0
+ (LONG (6 8) (5 0) (5 0) (16 0))))
+
+;; Branch-tensioned instructions are in instr2.scm
+;; Floating point instructions are in instr3.scm
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr2a.scm,v 1.1 1990/05/07 04:14:17 jinx Exp $
+
+Copyright (c) 1987, 1989, 1990 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. |#
+
+;;;; MIPS instruction set, part 2a
+
+(declare (usual-integrations))
+\f
+;;;; Instructions that require branch tensioning: branch
+
+(let-syntax
+ ((branch
+ (macro (keyword match-phrase forward reverse)
+ `(define-instruction ,keyword
+ ((,@match-phrase (@PCO (? branch-dest-pco)))
+ (VARIABLE-WIDTH (offset (/ branch-dest-pco 4))
+ ((#x-8000 #x7fff) (LONG ,@forward (16 offset signed)))
+ ((() ()) (LONG (32 "Can't branch tension @PCO operands")))))
+ ((,@match-phrase (@PCR (? branch-dest-pcr)))
+ (VARIABLE-WIDTH (offset `(/ (- ,branch-dest-pcr (+ *PC* 4)) 4))
+ ((#x-8000 #x7fff) (LONG ,@forward (16 offset signed)))
+ ((() ())
+ ;; <reverse> xxx
+ ;; LUI $1,left_adj(branch-dest - 16)
+ ;; BGEZAL $0,yyy
+ ;; ADDIU $1,$1,right(branch-dest - 16)
+ ;; yyy: ADD $1,$1,$31
+ ;; JR $1
+ ;; ADD $0,$0,$0
+ ;; xxx:
+ (LONG ,@reverse (16 6) ; reverse branch to (.+1)+6
+ (6 15) ; LUI
+ (5 0)
+ (5 1)
+ (16 (adjusted:high offset))
+ (6 1) ; BGEZAL
+ (5 0)
+ (5 17)
+ (16 1)
+ (6 9) ; ADDIU
+ (5 1)
+ (5 1)
+ (16 (adjusted:low offset) SIGNED)
+ (6 0) ; ADD
+ (5 1)
+ (5 31)
+ (5 1)
+ (5 0)
+ (6 32)
+ (6 0) ; JR
+ (5 1)
+ (15 0)
+ (6 8)
+ (6 0) ; ADD
+ (5 0)
+ (5 0)
+ (5 0)
+ (5 0)
+ (6 32)))))))))
+ (branch bc0f () ((6 16) (10 #x100)) ((6 16) (10 #x101)))
+ (branch bc1f () ((6 17) (10 #x100)) ((6 17) (10 #x101)))
+ (branch bc2f () ((6 18) (10 #x100)) ((6 18) (10 #x101)))
+ (branch bc3f () ((6 19) (10 #x100)) ((6 19) (10 #x101)))
+ (branch bc0t () ((6 16) (10 #x101)) ((6 16) (10 #x100)))
+ (branch bc1t () ((6 17) (10 #x101)) ((6 17) (10 #x100)))
+ (branch bc2t () ((6 18) (10 #x101)) ((6 18) (10 #x100)))
+ (branch bc3t () ((6 19) (10 #x101)) ((6 19) (10 #x100)))
+ (branch beq ((? reg1) (? reg2))
+ ((6 4) (5 reg1) (5 reg2))
+ ((6 5) (5 reg1) (5 reg2)))
+ (branch bgez ((? reg))
+ ((6 1) (5 reg) (5 1))
+ ((6 1) (5 reg) (5 0)))
+ (branch bgezal ((? reg))
+ ((6 1) (5 reg) (5 17))
+ ((16 can not branch tension a bgezal instruction)))
+ (branch bgtz ((? reg))
+ ((6 7) (5 reg) (5 0))
+ ((6 6) (5 reg) (5 0)))
+ (branch blez ((? reg))
+ ((6 6) (5 reg) (5 0))
+ ((6 7) (5 reg) (5 0)))
+ (branch bltz ((? reg))
+ ((6 1) (5 reg) (5 0))
+ ((6 1) (5 reg) (5 1)))
+ (branch bltzal ((? reg))
+ ((6 1) (5 reg) (5 16))
+ ((16 can not branch tension a bltzal instruction)))
+ (branch bne ((? reg1) (? reg2))
+ ((6 5) (5 reg1) (5 reg2))
+ ((6 4) (5 reg1) (5 reg2))))
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr2b.scm,v 1.1 1990/05/07 04:14:32 jinx Rel $
+
+Copyright (c) 1987, 1989, 1990 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. |#
+
+;;;; MIPS instruction set, part 2b
+
+(declare (usual-integrations))
+\f
+;;;; Instructions that require branch tensioning: load/store
+
+(let-syntax
+ ((load/store-instruction
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? source/dest-reg) (OFFSET (? offset-ls) (? base-reg)))
+ (VARIABLE-WIDTH (delta offset-ls)
+ ((#x-8000 #x7fff)
+ (LONG (6 ,opcode)
+ (5 base-reg)
+ (5 source/dest-reg)
+ (16 offset-ls SIGNED)))
+ ((() ())
+ ;; LUI 1,adjusted-left<offset>
+ ;; ADDU 1,1,base-reg
+ ;; LW source/dest-reg,right<offset>(1)
+ (LONG (6 15) ; LUI
+ (5 0)
+ (5 1)
+ (16 (adjusted:high offset-ls))
+ (6 0) ; ADD
+ (5 1)
+ (5 base-reg)
+ (5 1)
+ (5 0)
+ (6 32)
+ (6 ,opcode); LW
+ (5 1)
+ (5 source/dest-reg)
+ (16 (adjusted:low offset-ls) SIGNED)))))
+ (((? source/dest-reg) (@PCR (? label)))
+ (VARIABLE-WIDTH (delta `(- ,label (+ *PC* 8)))
+ ((#x-8000 #x7fff)
+ ; BGEZAL 0,X
+ ; LW source/dest-reg,delta(31)
+ ; X:
+ (LONG (6 1) ; BGEZAL
+ (5 0)
+ (5 17)
+ (16 1)
+ (6 ,opcode) ; LW
+ (5 31)
+ (5 source/dest-reg)
+ (16 delta)))
+ ((() ())
+ ; BGEZAL 0,X
+ ; LUI 1,upper-half-adjusted
+ ; X: ADDU 1,31,1
+ ; LW source/dest-reg,lower-half(1)
+ (LONG (6 1) ; BGEZAL
+ (5 0)
+ (5 17)
+ (16 1)
+ (6 15) ; LUI
+ (5 0)
+ (5 1)
+ (16 (adjusted:high delta))
+ (6 0) ; ADDU
+ (5 1)
+ (5 31)
+ (5 1)
+ (5 0)
+ (6 33)
+ (6 ,opcode) ; LW
+ (5 1)
+ (5 source/dest-reg)
+ (16 (adjusted:low delta) SIGNED)))))))))
+ (load/store-instruction lb 32)
+ (load/store-instruction lbu 36)
+ (load/store-instruction lh 33)
+ (load/store-instruction lhu 37)
+ (load/store-instruction lw 35)
+ (load/store-instruction lwc0 48)
+ (load/store-instruction lwc1 49)
+ (load/store-instruction lwc2 50)
+ (load/store-instruction lwc3 51)
+ (load/store-instruction lwl 34)
+ (load/store-instruction lwr 38)
+ (load/store-instruction sb 40)
+ (load/store-instruction sh 41)
+ (load/store-instruction sw 43)
+ (load/store-instruction swc0 56)
+ (load/store-instruction swc1 57)
+ (load/store-instruction swc2 58)
+ (load/store-instruction swc3 59)
+ (load/store-instruction swl 42)
+ (load/store-instruction swr 46))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr3.scm,v 1.1 1990/05/07 04:14:47 jinx Rel $
+
+Copyright (c) 1987, 1989, 1990 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. |#
+
+;;;; MIPS instruction set, part 3
+
+(declare (usual-integrations))
+;;;; Floating point co-processor (R2010)
+
+(let-syntax
+ ((three-reg
+ (macro (keyword function-code)
+ `(define-instruction ,keyword
+ ((SINGLE (? fd) (? fs) (? ft))
+ (LONG (6 17)
+ (1 1)
+ (4 0) ; single precision
+ (5 ft)
+ (5 fs)
+ (5 fd)
+ (6 ,function-code)))
+ ((DOUBLE (? fd) (? fs) (? ft))
+ (LONG (6 17)
+ (1 1)
+ (4 1) ; double precision
+ (5 ft)
+ (5 fs)
+ (5 fd)
+ (6 ,function-code))))))
+ (two-reg
+ (macro (keyword function-code)
+ `(define-instruction ,keyword
+ ((SINGLE (? fd) (? fs))
+ (LONG (6 17)
+ (1 1)
+ (4 0) ; single precision
+ (5 0)
+ (5 fs)
+ (5 fd)
+ (6 ,function-code)))
+ ((DOUBLE (? fd) (? fs))
+ (LONG (6 17)
+ (1 1)
+ (4 1) ; double precision
+ (5 0)
+ (5 fs)
+ (5 fd)
+ (6 ,function-code))))))
+ (compare
+ (macro (keyword conditions)
+ `(define-instruction ,keyword
+ ((SINGLE (? fs) (? ft))
+ (LONG (6 17)
+ (1 1)
+ (4 0) ; single precision
+ (5 ft)
+ (5 fs)
+ (5 0)
+ (6 ,conditions)))
+ ((DOUBLE (? fs) (? ft))
+ (LONG (6 17)
+ (1 1)
+ (4 1) ; double precision
+ (5 ft)
+ (5 fs)
+ (5 0)
+ (6 ,conditions)))))))
+
+ (three-reg fadd 0)
+ (three-reg fsub 1)
+ (three-reg fmul 2)
+ (three-reg fdiv 3)
+ (two-reg fabs 5)
+ (two-reg fmov 6)
+ (two-reg fneg 7)
+ (two-reg cvt.s 32)
+ (two-reg cvt.d 33)
+ (two-reg cvt.w 36)
+ (compare c.f 48)
+ (compare c.un 49)
+ (compare c.eq 50)
+ (compare c.ueq 51)
+ (compare c.olt 52)
+ (compare c.ult 53)
+ (compare c.ole 54)
+ (compare c.ule 55)
+ (compare c.sf 56)
+ (compare c.ngle 57)
+ (compare c.seq 58)
+ (compare c.ngl 59)
+ (compare c.lt 60)
+ (compare c.nge 61)
+ (compare c.le 62)
+ (compare c.ngt 63))
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/lapgen.scm,v 1.1 1990/05/07 04:15:06 jinx Exp $
+$MC68020-Header: lapgen.scm,v 4.26 90/01/18 22:43:36 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rules for MIPS. Shared utilities.
+
+(declare (usual-integrations))
+\f
+;;;; Register-Allocator Interface
+
+(define (register->register-transfer source target)
+ (if (not (register-types-compatible? source target))
+ (error "Moving between incompatible register types" source target))
+ (case (register-type source)
+ ((GENERAL) (copy source target))
+ ((FLOAT) (fp-copy source target))
+ (else (error "unknown register type" source))))
+
+(define (home->register-transfer source target)
+ (memory->register-transfer (pseudo-register-displacement source)
+ regnum:regs-pointer
+ target))
+
+(define (register->home-transfer source target)
+ (register->memory-transfer source
+ (pseudo-register-displacement target)
+ regnum:regs-pointer))
+
+(define (reference->register-transfer source target)
+ (case (ea/mode source)
+ ((GR)
+ (copy (register-ea/register source) target))
+ ((FPR)
+ (fp-copy (fpr->float-register (register-ea/register source)) target))
+ ((OFFSET)
+ (memory->register-transfer (offset-ea/offset source)
+ (offset-ea/register source)
+ target))
+ (else
+ (error "unknown effective-address mode" source))))
+
+(define (pseudo-register-home register)
+ ;; Register block consists of 16 4-byte registers followed by 256
+ ;; 8-byte temporaries.
+ (INST-EA (OFFSET ,(pseudo-register-displacement register)
+ ,regnum:regs-pointer)))
+\f
+(define-integrable (sort-machine-registers registers)
+ registers)
+
+(define available-machine-registers
+ (list
+ ;; g0 g1 g2 g3 g4
+ ;; g8 g9 g10 g11
+ g12 g13 g14 g15 g16 g17 g18 g19
+ ;; g20 g21 g22
+ g23 g24
+ ;; g26 g27 g28 g29
+ g30
+ g5 g6 g7 g25 ; Allocate last
+ ;; g31
+ fp0 fp2 fp4 fp6 fp8 fp10 fp12 fp14
+ fp16 fp18 fp20 fp22 fp24 fp26 fp28 fp30
+ ;; fp1 fp3 fp5 fp7 fp9 fp11 fp13 fp15
+ ;; fp17 fp19 fp21 fp23 fp25 fp27 fp29 fp31
+ ))
+
+(define-integrable (float-register? register)
+ (eq? (register-type register) 'FLOAT))
+
+(define-integrable (general-register? register)
+ (eq? (register-type register) 'GENERAL))
+
+(define-integrable (word-register? register)
+ (eq? (register-type register) 'GENERAL))
+
+(define (register-types-compatible? type1 type2)
+ (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
+
+(define (register-type register)
+ (cond ((machine-register? register)
+ (vector-ref
+ '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
+ register))
+ ((register-value-class=word? register) 'GENERAL)
+ ((register-value-class=float? register) 'FLOAT)
+ (else (error "unable to determine register type" register))))
+
+(define register-reference
+ (let ((references (make-vector number-of-machine-registers)))
+ (let loop ((register 0))
+ (if (< register 32)
+ (begin
+ (vector-set! references register (INST-EA (GR ,register)))
+ (loop (1+ register)))))
+ (let loop ((register 32) (fpr 0))
+ (if (< register 48)
+ (begin
+ (vector-set! references register (INST-EA (FPR ,fpr)))
+ (loop (1+ register) (1+ fpr)))))
+ (lambda (register)
+ (vector-ref references register))))
+\f
+;;;; Useful Cliches
+
+(define (memory->register-transfer offset base target)
+ (case (register-type target)
+ ((GENERAL) (LAP (LW ,target (OFFSET ,offset ,base))
+ (NOP)))
+ ((FLOAT) (fp-load-doubleword offset base target #T))
+ (else (error "unknown register type" target))))
+
+(define (register->memory-transfer source offset base)
+ (case (register-type source)
+ ((GENERAL) (LAP (SW ,source (OFFSET ,offset ,base))))
+ ((FLOAT) (fp-store-doubleword source offset base))
+ (else (error "unknown register type" source))))
+
+(define (load-constant constant target #!optional delay)
+ ;; Load a Scheme constant into a machine register.
+ (let ((delay (and (not (default-object? delay)) delay)))
+ (if (non-pointer-object? constant)
+ (load-immediate (non-pointer->literal constant) target)
+ (LAP ,@(load-pc-relative (constant->label constant) target)
+ ,@(if delay '((NOP)) '())))))
+
+(define (load-non-pointer type datum target)
+ ;; Load a Scheme non-pointer constant, defined by type and datum,
+ ;; into a machine register.
+ (load-immediate (make-non-pointer-literal type datum) target))
+
+(define (non-pointer->literal constant)
+ (make-non-pointer-literal (object-type constant)
+ (careful-object-datum constant)))
+
+(define-integrable (make-non-pointer-literal type datum)
+ (+ (* type (expt 2 scheme-datum-width)) datum))
+
+(define-integrable (deposit-type type-num target-reg)
+ (if (= target-reg regnum:assembler-temp)
+ (error "deposit-type: into register 1"))
+ (LAP (AND ,target-reg ,target-reg ,regnum:address-mask)
+ ,@(put-type type-num target-reg)))
+
+(define-integrable (put-type type-num target-reg)
+ ; Assumes that target-reg has 0 in type bits
+ (LAP (LUI ,regnum:assembler-temp
+ ,(* type-scale-factor #x100 type-num))
+ (OR ,target-reg ,regnum:assembler-temp ,target-reg)))
+\f
+;;;; Regularized Machine Instructions
+
+(define (copy r t)
+ (if (= r t)
+ (LAP)
+ (LAP (ADD ,t 0 ,r))))
+
+(define-integrable (long->bits long)
+ ((if (negative? long)
+ signed-integer->bit-string
+ unsigned-integer->bit-string) 32 long))
+
+(define (adjusted:high long)
+ (let ((n (long->bits long)))
+ (+ (extract n 16 32)
+ (if (> (extract n 0 16) #x7FFF)
+ 1 0))))
+
+(define (adjusted:low long)
+ (extract-signed (long->bits long) 0 16))
+
+(define (top-16-bits long)
+ (extract (long->bits long) 16 32))
+
+(define (add-immediate value source dest)
+ (cond
+ ((fits-in-16-bits-signed? value)
+ (LAP (ADDI ,dest ,source ,value)))
+ ((top-16-bits-only? value)
+ (LAP (LUI ,regnum:assembler-temp ,(top-16-bits value))
+ (ADD ,dest ,regnum:assembler-temp ,source)))
+ (else
+ (LAP (ADDIU ,dest ,source ,(adjusted:low value))
+ (LUI ,regnum:assembler-temp ,(adjusted:high value))
+ (ADD ,dest ,dest ,regnum:assembler-temp)))))
+
+(define (load-immediate value dest)
+ (cond
+ ((fits-in-16-bits-signed? value)
+ (LAP (ADDI ,dest 0 ,value)))
+ ((top-16-bits-only? value)
+ (LAP (LUI ,dest ,(top-16-bits value))))
+ ((fits-in-16-bits-unsigned? value)
+ (LAP (ORI ,dest 0 ,value)))
+ (else
+ (LAP
+ (LUI ,regnum:assembler-temp ,(adjusted:high value))
+ (ADDIU ,dest ,regnum:assembler-temp ,(adjusted:low value))))))
+\f
+(define (fp-copy from to)
+ (if (= r t)
+ (LAP)
+ (LAP (FMOV DOUBLE ,(float-register->fpr to)
+ ,(float-register->fpr from)))))
+
+;; Handled by VARIABLE-WIDTH in instr1.scm
+
+(define-integrable (fp-load-doubleword offset base target NOP?)
+ (LAP (LWC1 ,(float-register->fpr target)
+ (OFFSET ,offset ,base))
+ (LWC1 ,(+ (float-register->fpr target) 1)
+ (OFFSET ,(+ offset 4) ,base))
+ ,@(if NOP? (LAP (NOP)) (LAP))))
+
+(define-integrable (fp-store-doubleword offset base source)
+ (LAP (SWC1 ,(float-register->fpr source)
+ (OFFSET ,offset ,base))
+ (SWC1 ,(+ (float-register->fpr source) 1)
+ (OFFSET ,(+ offset 4) ,base))))
+
+(define (load-pc-relative label target)
+ ;; Load a pc-relative location's contents into a machine register.
+ (LAP (LW ,target (@PCR ,label))))
+
+(define (load-pc-relative-address label target)
+ ;; Load address of a pc-relative location into a machine register.
+ (LAP (PC-RELATIVE-OFFSET ,target (@PCR ,label))))
+\f
+(define (branch-generator! cc = < > <> >= <=)
+ (let ((forward
+ (case cc
+ ((=) =) ((<) <) ((>) >)
+ ((<>) <>) ((>=) >=) ((<=) <=)))
+ (inverse
+ (case cc
+ ((=) <>) ((<) >=) ((>) <=)
+ ((<>) =) ((>=) <) ((<=) >))))
+ (set-current-branches!
+ (lambda (label)
+ (LAP (,@forward (@PCR ,label)) (NOP)))
+ (lambda (label)
+ (LAP (,@inverse (@PCR ,label)) (NOP))))))
+
+(define (compare-immediate comp i r2)
+ ; Branch if immediate <comp> r2
+ (let ((cc (invert-condition-noncommutative comp)))
+ ;; This machine does register <op> immediate; you can
+ ;; now think of cc in this way
+ (if (zero? i)
+ (begin
+ (branch-generator! cc
+ `(BEQ 0 ,r2) `(BLTZ ,r2) `(BGTZ ,r2)
+ `(BNE 0 ,r2) `(BGEZ ,r2) `(BLEZ ,r2))
+ (LAP))
+ (let ((temp (standard-temporary!)))
+ (if (fits-in-16-bits-signed? i)
+ (begin
+ (branch-generator! cc
+ `(BEQ ,temp ,r2) `(BNE 0 ,temp) `(BEQ 0 ,temp)
+ `(BNE ,temp ,r2) `(BEQ 0 ,temp) `(BNE 0 ,temp))
+ (case cc
+ ((= <>) (LAP (ADDI ,temp 0 ,i)))
+ ((< >=) (LAP (SLTI ,temp ,r2 ,i)))
+ ((> <=) (LAP (SLTI ,temp ,r2 ,(+ i 1))))))
+ (LAP ,@(load-immediate i temp)
+ ,@(compare comp temp r2)))))))
+
+(define (compare condition r1 r2)
+ ; Branch if r1 <cc> r2
+ (let ((temp (if (memq condition '(< > <= >=))
+ (standard-temporary!)
+ '())))
+ (branch-generator! condition
+ `(BEQ ,r1 ,r2) `(BNE ,temp 0) `(BNE ,temp 0)
+ `(BNE ,r1 ,r2) `(BEQ ,temp 0) `(BEQ ,temp 0))
+ (case condition
+ ((= <>) (LAP))
+ ((< >=) (LAP (SLT ,temp ,r1 ,r2)))
+ ((> <=) (LAP (SLT ,temp ,r2 ,r1))))))
+\f
+;;;; Conditions
+
+(define (invert-condition condition)
+ (let ((place (assq condition condition-inversion-table)))
+ (if (not place)
+ (error "unknown condition" condition))
+ (cadr place)))
+
+(define (invert-condition-noncommutative condition)
+ (let ((place (assq condition condition-inversion-table)))
+ (if (not place)
+ (error "unknown condition" condition))
+ (caddr place)))
+
+(define condition-inversion-table
+ ; A OP B NOT (A OP B) B OP A
+ ; invert invert non-comm.
+ '((= <> =)
+ (< >= >)
+ (> <= <)
+ (<> = <>)
+ (<= > >=)
+ (>= < <=)))
+\f
+;;;; Miscellaneous
+
+(define-integrable (object->datum src tgt)
+ ; Zero out the type field; don't put in the quad bits
+ (LAP (AND ,tgt ,regnum:address-mask ,src)))
+
+(define-integrable (object->address reg)
+ ; Drop in the segment bits
+ (LAP (AND ,reg ,regnum:address-mask ,reg)
+ ,@(put-address-bits reg)))
+
+(define-integrable (put-address-bits reg)
+ ; Drop in the segment bits, assuming they are currently 0
+ (LAP (OR ,reg ,reg ,regnum:quad-bits)))
+
+(define-integrable (object->type src tgt)
+ ; Type extraction
+ (LAP (SRL ,tgt ,src ,(- 32 scheme-type-width))))
+
+(define (standard-unary-conversion source target conversion)
+ ;; `source' is any register, `target' a pseudo register.
+ (let ((source (standard-source! source)))
+ (conversion source (standard-target! target))))
+
+(define (standard-binary-conversion source1 source2 target conversion)
+ (let ((source1 (standard-source! source1))
+ (source2 (standard-source! source2)))
+ (conversion source1 source2 (standard-target! target))))
+
+(define (standard-source! register)
+ (load-alias-register! register (register-type register)))
+
+(define (standard-target! register)
+ (delete-dead-registers!)
+ (allocate-alias-register! register (register-type register)))
+
+(define-integrable (standard-temporary!)
+ (allocate-temporary-register! 'GENERAL))
+
+(define (standard-move-to-target! source target)
+ (move-to-alias-register! source (register-type source) target))
+
+(define (standard-move-to-temporary! source)
+ (move-to-temporary-register! source (register-type source)))
+
+(define (register-expression expression)
+ (case (rtl:expression-type expression)
+ ((REGISTER)
+ (rtl:register-number expression))
+ ((CONSTANT)
+ (let ((object (rtl:constant-value expression)))
+ (and (zero? (object-type object))
+ (zero? (object-datum object))
+ 0)))
+ ((CONS-POINTER)
+ (and (let ((type (rtl:cons-pointer-type expression)))
+ (and (rtl:machine-constant? type)
+ (zero? (rtl:machine-constant-value type))))
+ (let ((datum (rtl:cons-pointer-datum expression)))
+ (and (rtl:machine-constant? datum)
+ (zero? (rtl:machine-constant-value datum))))
+ 0))
+ (else false)))
+\f
+(define (define-arithmetic-method operator methods method)
+ (let ((entry (assq operator (cdr methods))))
+ (if entry
+ (set-cdr! entry method)
+ (set-cdr! methods (cons (cons operator method) (cdr methods)))))
+ operator)
+
+(define (lookup-arithmetic-method operator methods)
+ (cdr (or (assq operator (cdr methods))
+ (error "Unknown operator" operator))))
+
+(define (fits-in-16-bits-signed? value)
+ (<= #x-8000 value #x7FFF))
+
+(define (fits-in-16-bits-unsigned? value)
+ (<= #x0 value #xFFFF))
+
+(define (top-16-bits-only? value)
+ (zero? (remainder value #x10000)))
+
+(define-integrable (ea/mode ea) (car ea))
+(define-integrable (register-ea/register ea) (cadr ea))
+(define-integrable (offset-ea/offset ea) (cadr ea))
+(define-integrable (offset-ea/register ea) (caddr ea))
+
+(define (pseudo-register-displacement register)
+ ;; Register block consists of 16 4-byte registers followed by 256
+ ;; 8-byte temporaries.
+ (+ (* 4 16) (* 8 (register-renumber register))))
+
+(define-integrable (float-register->fpr register)
+ ;; Float registers are represented by 32 through 47 in the RTL,
+ ;; corresponding to even registers 0 through 30 in the machine.
+ (- register 32))
+
+(define-integrable (fpr->float-register register)
+ (+ register 32))
+
+(define-integrable reg:memtop
+ (INST-EA (OFFSET #x0000 ,regnum:regs-pointer)))
+
+(define-integrable reg:environment
+ (INST-EA (OFFSET #x000C ,regnum:regs-pointer)))
+
+(define-integrable reg:lexpr-primitive-arity
+ (INST-EA (OFFSET #x001C ,regnum:regs-pointer)))
+
+(define (lap:make-label-statement label)
+ (INST (LABEL ,label)))
+
+(define (lap:make-unconditional-branch label)
+ (LAP (BEQ 0 0 (@PCR ,label))
+ (NOP)))
+
+(define (lap:make-entry-point label block-start-label)
+ block-start-label
+ (LAP (ENTRY-POINT ,label)
+ ,@(make-external-label expression-code-word label)))
+\f
+;;;; Codes and Hooks
+
+(let-syntax ((define-codes
+ (macro (start . names)
+ (define (loop names index)
+ (if (null? names)
+ '()
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'CODE:COMPILER-
+ (car names))
+ ,index)
+ (loop (cdr names) (1+ index)))))
+ `(BEGIN ,@(loop names start)))))
+ (define-codes #x012
+ primitive-apply primitive-lexpr-apply
+ apply error lexpr-apply link
+ interrupt-closure interrupt-dlink interrupt-procedure
+ interrupt-continuation interrupt-ic-procedure
+ assignment-trap cache-reference-apply
+ reference-trap safe-reference-trap unassigned?-trap
+ -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
+ access lookup safe-lookup unassigned? unbound?
+ set! define lookup-apply))
+
+(define-integrable (link-to-interface code)
+ ;; Jump, with link in 31, to link_to_interface
+ (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -100)
+ (JALR ,regnum:linkage ,regnum:assembler-temp)
+ (ADDI ,regnum:interface-index 0 ,(* 4 code))))
+
+(define-integrable (link-to-trampoline code)
+ ;; Jump, with link in 31, to trampoline_to_interface
+ (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -96)
+ (JALR ,regnum:linkage ,regnum:assembler-temp)
+ (ADDI ,regnum:interface-index 0 ,(* 4 code))))
+
+(define-integrable (invoke-interface code)
+ ;; Jump to scheme-to-interface
+ (LAP (JR ,regnum:scheme-to-interface)
+ (ADDI ,regnum:interface-index 0 ,(* 4 code))))
+
+(define (load-interface-args! first second third fourth)
+ (let ((clear-regs
+ (apply clear-registers!
+ (append (if first (list regnum:first-arg) '())
+ (if second (list regnum:second-arg) '())
+ (if third (list regnum:third-arg) '()))))
+ (load-reg
+ (lambda (reg arg)
+ (if reg (load-machine-register! reg arg) (LAP)))))
+ (let ((load-regs
+ (LAP ,@(load-reg first regnum:second-arg)
+ ,@(load-reg second regnum:third-arg)
+ ,@(load-reg third regnum:fourth-arg)
+ ,@(if fourth
+ (let ((temp (standard-temporary!)))
+ (LAP
+ ,@(load-machine-register! fourth temp)
+ (SW ,temp
+ (OFFSET 16 ,regnum:C-stack-pointer))))
+ (LAP)))))
+ (LAP ,@clear-regs
+ ,@load-regs
+ ,@(clear-map!)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/machin.scm,v 1.1 1990/05/07 04:15:24 jinx Exp $
+$MC68020-Header: machin.scm,v 4.20 90/01/18 22:43:44 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 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. |#
+
+;;; Machine Model for MIPS
+
+(declare (usual-integrations))
+\f
+;;;; Architecture Parameters
+
+(define-integrable endianness 'LITTLE)
+(define-integrable addressing-granularity 8)
+(define-integrable scheme-object-width 32)
+(define-integrable scheme-type-width 6) ;or 8
+
+(define-integrable scheme-datum-width
+ (- scheme-object-width scheme-type-width))
+
+(define-integrable type-scale-factor
+ (expt 2 (- 8 scheme-type-width)))
+
+(define-integrable flonum-size 2)
+(define-integrable float-alignment 64)
+
+;;; It is currently required that both packed characters and objects
+;;; be integrable numbers of address units. Furthermore, the number
+;;; of address units per object must be an integral multiple of the
+;;; number of address units per character. This will cause problems
+;;; on a machine that is word addressed, in which case we will have to
+;;; rethink the character addressing strategy.
+
+(define-integrable address-units-per-object
+ (quotient scheme-object-width addressing-granularity))
+
+(define-integrable address-units-per-packed-char 1)
+
+(define-integrable signed-fixnum/upper-limit (expt 2 (-1+ scheme-datum-width)))
+(define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit))
+(define-integrable unsigned-fixnum/upper-limit (* 2 signed-fixnum/upper-limit))
+
+(define-integrable (stack->memory-offset offset) offset)
+(define-integrable ic-block-first-parameter-offset 2)
+(define-integrable closure-block-first-offset 2)
+(define-integrable execute-cache-size 2) ; Long words per UUO link slot
+\f
+;;;; Machine Registers
+
+(define-integrable g0 0)
+(define-integrable g1 1)
+(define-integrable g2 2)
+(define-integrable g3 3)
+(define-integrable g4 4)
+(define-integrable g5 5)
+(define-integrable g6 6)
+(define-integrable g7 7)
+(define-integrable g8 8)
+(define-integrable g9 9)
+(define-integrable g10 10)
+(define-integrable g11 11)
+(define-integrable g12 12)
+(define-integrable g13 13)
+(define-integrable g14 14)
+(define-integrable g15 15)
+(define-integrable g16 16)
+(define-integrable g17 17)
+(define-integrable g18 18)
+(define-integrable g19 19)
+(define-integrable g20 20)
+(define-integrable g21 21)
+(define-integrable g22 22)
+(define-integrable g23 23)
+(define-integrable g24 24)
+(define-integrable g25 25)
+(define-integrable g26 26)
+(define-integrable g27 27)
+(define-integrable g28 28)
+(define-integrable g29 29)
+(define-integrable g30 30)
+(define-integrable g31 31)
+
+;; Floating point general registers -- the odd numbered ones are
+;; only used when transferring to/from the CPU
+(define-integrable fp0 32)
+(define-integrable fp1 33)
+(define-integrable fp2 34)
+(define-integrable fp3 35)
+(define-integrable fp4 36)
+(define-integrable fp5 37)
+(define-integrable fp6 38)
+(define-integrable fp7 39)
+(define-integrable fp8 40)
+(define-integrable fp9 41)
+(define-integrable fp10 42)
+(define-integrable fp11 43)
+(define-integrable fp12 44)
+(define-integrable fp13 45)
+(define-integrable fp14 46)
+(define-integrable fp15 47)
+(define-integrable fp16 48)
+(define-integrable fp17 49)
+(define-integrable fp18 50)
+(define-integrable fp19 51)
+(define-integrable fp20 52)
+(define-integrable fp21 53)
+(define-integrable fp22 54)
+(define-integrable fp23 55)
+(define-integrable fp24 56)
+(define-integrable fp25 57)
+(define-integrable fp26 58)
+(define-integrable fp27 59)
+(define-integrable fp28 60)
+(define-integrable fp29 61)
+(define-integrable fp30 62)
+(define-integrable fp31 63)
+
+(define-integrable number-of-machine-registers 63)
+(define-integrable number-of-temporary-registers 256)
+\f
+;;; Fixed-use registers for Scheme compiled code.
+(define-integrable regnum:return-value g2)
+(define-integrable regnum:stack-pointer g3)
+(define-integrable regnum:memtop g8)
+(define-integrable regnum:free g9)
+(define-integrable regnum:scheme-to-interface g10)
+(define-integrable regnum:dynamic-link g11)
+(define-integrable regnum:address-mask g20)
+(define-integrable regnum:regs-pointer g21)
+(define-integrable regnum:quad-bits g22)
+(define-integrable regnum:interface-index g25)
+
+;;; Fixed-use registers due to architecture or OS calling conventions.
+(define-integrable regnum:zero g0)
+(define-integrable regnum:assembler-temp g1)
+(define-integrable regnum:C-return-value g2)
+(define-integrable regnum:first-arg g4)
+(define-integrable regnum:second-arg g5)
+(define-integrable regnum:third-arg g6)
+(define-integrable regnum:fourth-arg g7)
+(define-integrable regnum:kernel-reserved-1 g26)
+(define-integrable regnum:kernel-reserved-2 g27)
+(define-integrable regnum:C-global-pointer g28)
+(define-integrable regnum:C-stack-pointer g29)
+(define-integrable regnum:linkage g31)
+
+(define machine-register-value-class
+ (let ((special-registers
+ `((,regnum:return-value . ,value-class=object)
+ (,regnum:stack-pointer . ,value-class=address)
+ (,regnum:memtop . ,value-class=address)
+ (,regnum:free . ,value-class=address)
+ (,regnum:scheme-to-interface . ,value-class=unboxed)
+ (,regnum:dynamic-link . ,value-class=address)
+ (,regnum:address-mask . ,value-class=immediate)
+ (,regnum:regs-pointer . ,value-class=unboxed)
+ (,regnum:quad-bits . ,value-class=immediate)
+ (,regnum:assembler-temp . ,value-class=unboxed)
+ (,regnum:kernel-reserved-1 . ,value-class=unboxed)
+ (,regnum:kernel-reserved-2 . ,value-class=unboxed)
+ (,regnum:C-global-pointer . ,value-class=unboxed)
+ (,regnum:C-stack-pointer . ,value-class=unboxed)
+ (,regnum:linkage . ,value-class=address))))
+ (lambda (register)
+ (let ((lookup (assv register special-registers)))
+ (cond
+ ((not (null? lookup)) (cdr lookup))
+ ((<= g0 register g31) value-class=word)
+ ((<= fp0 register fp31) value-class=float)
+ (else (error "illegal machine register" register)))))))
+
+(define-integrable (machine-register-known-value register)
+ register ;ignore
+ false)
+\f
+;;;; Interpreter Registers
+
+(define-integrable (interpreter-free-pointer)
+ (rtl:make-machine-register regnum:free))
+
+(define (interpreter-free-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:free)))
+
+(define-integrable (interpreter-regs-pointer)
+ (rtl:make-machine-register regnum:regs-pointer))
+
+(define (interpreter-regs-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:regs-pointer)))
+
+(define-integrable (interpreter-value-register)
+ (rtl:make-machine-register regnum:return-value))
+
+(define (interpreter-value-register? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:return-value)))
+
+(define-integrable (interpreter-stack-pointer)
+ (rtl:make-machine-register regnum:stack-pointer))
+
+(define (interpreter-stack-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:stack-pointer)))
+
+(define-integrable (interpreter-dynamic-link)
+ (rtl:make-machine-register regnum:dynamic-link))
+
+(define (interpreter-dynamic-link? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:dynamic-link)))
+
+(define-integrable (interpreter-environment-register)
+ (rtl:make-offset (interpreter-regs-pointer) 3))
+
+(define (interpreter-environment-register? expression)
+ (and (rtl:offset? expression)
+ (interpreter-regs-pointer? (rtl:offset-base expression))
+ (= 3 (rtl:offset-number expression))))
+
+(define-integrable (interpreter-register:access)
+ (rtl:make-machine-register regnum:C-return-value))
+
+(define-integrable (interpreter-register:cache-reference)
+ (rtl:make-machine-register regnum:C-return-value))
+
+(define-integrable (interpreter-register:cache-unassigned?)
+ (rtl:make-machine-register regnum:C-return-value))
+
+(define-integrable (interpreter-register:lookup)
+ (rtl:make-machine-register regnum:C-return-value))
+
+(define-integrable (interpreter-register:unassigned?)
+ (rtl:make-machine-register regnum:C-return-value))
+
+(define-integrable (interpreter-register:unbound?)
+ (rtl:make-machine-register regnum:C-return-value))
+\f
+;;;; RTL Registers, Constants, and Primitives
+
+(define (rtl:machine-register? rtl-register)
+ (case rtl-register
+ ((STACK-POINTER)
+ (interpreter-stack-pointer))
+ ((DYNAMIC-LINK)
+ (interpreter-dynamic-link))
+ ((VALUE)
+ (interpreter-value-register))
+ ((INTERPRETER-CALL-RESULT:ACCESS)
+ (interpreter-register:access))
+ ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
+ (interpreter-register:cache-reference))
+ ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
+ (interpreter-register:cache-unassigned?))
+ ((INTERPRETER-CALL-RESULT:LOOKUP)
+ (interpreter-register:lookup))
+ ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
+ (interpreter-register:unassigned?))
+ ((INTERPRETER-CALL-RESULT:UNBOUND?)
+ (interpreter-register:unbound?))
+ (else false)))
+
+(define (rtl:interpreter-register? rtl-register)
+ (case rtl-register
+ ((MEMORY-TOP) 0)
+ ((STACK-GUARD) 1)
+ ((ENVIRONMENT) 3)
+ ((TEMPORARY) 4)
+ (else false)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown register type" locative)))
+
+(define (rtl:constant-cost expression)
+ ;; Magic numbers.
+ (let ((if-integer
+ (lambda (value)
+ (cond ((zero? value) 1)
+ ((or (fits-in-16-bits-signed? value)
+ (fits-in-16-bits-unsigned? value)
+ (top-16-bits-only? value))
+ 2)
+ (else 3)))))
+ (let ((if-synthesized-constant
+ (lambda (type datum)
+ (if-integer (make-non-pointer-literal type datum)))))
+ (case (rtl:expression-type expression)
+ ((CONSTANT)
+ (let ((value (rtl:constant-value expression)))
+ (if (non-pointer-object? value)
+ (if-synthesized-constant (object-type value)
+ (object-datum value))
+ 3)))
+ ((MACHINE-CONSTANT)
+ (if-integer (rtl:machine-constant-value expression)))
+ ((ENTRY:PROCEDURE
+ ENTRY:CONTINUATION
+ ASSIGNMENT-CACHE
+ VARIABLE-CACHE
+ OFFSET-ADDRESS)
+ 3)
+ ((CONS-POINTER)
+ (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
+ (rtl:machine-constant? (rtl:cons-pointer-datum expression))
+ (if-synthesized-constant
+ (rtl:machine-constant-value (rtl:cons-pointer-type expression))
+ (rtl:machine-constant-value
+ (rtl:cons-pointer-datum expression)))))
+ (else false)))))
+
+(define compiler:open-code-floating-point-arithmetic?
+ true)
+
+(define compiler:primitives-with-no-open-coding
+ '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER
+ INTEGER-QUOTIENT INTEGER-REMAINDER &/
+ FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS
+ FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND
+ FLONUM-REMAINDER FLONUM-SQRT))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/mips.scm,v 1.1 1990/05/07 04:08:55 jinx Rel $
+
+Copyright (c) 1987, 1989, 1990 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. |#
+
+;;;; MIPS instruction set
+
+(declare (usual-integrations))
+\f
+(let-syntax
+ ((opcodes (macro (suffix names)
+ (let loop ((value 0)
+ (names names)
+ (result '()))
+ (cond ((null? names) `(BEGIN ,@result))
+ ((null? (car names)) (loop (+ value 1) (cdr names) result))
+ (else
+ (loop (+ value 1) (cdr names)
+ (cons
+ `(define-integrable
+ ,(string->symbol
+ (string-append (symbol->string (car names)) suffix))
+ ,value)
+ result))))))))
+ ; OP CODES
+ (opcodes "-op"
+ (special bcond j jal beq bne blez bgtz ; 0 - 7
+ addi addiu slti sltiu andi ori xori lui ; 8 - 15
+ cop0 cop1 cop2 cop3 () () () () ; 16 - 23
+ () () () () () () () () ; 24 - 31
+ lb lh lwl lw lbu lhu lwr () ; 32 - 39
+ sb sh swl sw () () swr () ; 40 - 47
+ lwc0 lwc1 lwc2 lwc3 () () () () ; 48 - 55
+ swc0 swc1 swc2 swc3 () () () ())) ; 56 - 63
+
+ ; Special Function Codes
+ (opcodes "-funct"
+ (sll () srl sra sllv () srlv srav ; 0 - 7
+ jr jalr () () syscall break () () ; 8 - 15
+ mfhi mthi mflo mtlo () () () () ; 16 - 23
+ mult multu div divu () () () () ; 24 - 31
+ add addu sub subu and or xor nor ; 32 - 39
+ () () slt sltu () () () () ; 40 - 47
+ () () () () () () () () ; 48 - 55
+ () () () () () () () ())) ; 56 - 63
+
+ ; Condition codes for BCOND
+ (opcodes "-cond"
+ (bltz bgez () () () () () () ; 0 - 7
+ () () () () () () () () ; 8 - 15
+ bltzal bgezal () () () () () () ; 16 - 23
+ () () () () () () () ())) ; 24 - 31
+
+ ; Floating point function codes for use with COP1 instruction
+ (opcodes "f-op"
+ (add sub mul div () abs mov neg ; 0 - 7
+ () () () () () () () () ; 8 - 15
+ () () () () () () () () ; 16 - 23
+ () () () () () () () () ; 24 - 31
+ cvt.s cvt.d () () cvt.w () () () ; 32 - 39
+ () () () () () () () () ; 40 - 47
+ c.f c.un c.eq c.ueq c.olt c.ult c.ole c.ule ; 48 - 55
+ c.sf c.ngle c.seq c.ngl c.lt c.nge c.le c.ngt)) ; 56 - 63
+) ; let-syntax
+
+; Operations on co-processors (for BCzFD, BCzT, CFCz, COPz, CTCz,
+; MFCz, and MTCz instructions)
+; This is confusing ... according to the diagrams, these occupy bits
+; 16 through 25, inclusive (10 bits). But the tables indicate that
+; only bits 16, and 21 through 25 matter. In fact, bit 25 is always 0
+; since that denotes a COPz instruction; hence COPz has 32 encodings
+; and all the others have two encodings.
+
+(define-integrable mf-cp-op #x000)
+(define-integrable mt-cp-op #x080)
+(define-integrable bcf-cp-op #x100)
+(define-integrable bct-cp-op #x101)
+(define-integrable cf-cp-op #x040)
+(define-integrable ct-cp-op #x0C0)
+
+(define-integrable mf-cp-op-alternate #x001)
+(define-integrable mt-cp-op-alternate #x081)
+(define-integrable bcf-cp-op-alternate #x180)
+(define-integrable bct-cp-op-alternate #x181)
+(define-integrable cf-cp-op-alternate #x041)
+(define-integrable ct-cp-op-alternate #x0C1)
+
+; Operations on co-processor 0
+(define-integrable cop0-op:tlbr 1)
+(define-integrable cop0-op:tlbwi 2)
+(define-integrable cop0-op:tlbwr 6)
+(define-integrable cop0-op:tlbp 8)
+(define-integrable cop0-op:rfe 16)
+
+; Floating point formats
+(define-integrable single-precision-float 0)
+(define-integrable double-precision-float 1)
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rgspcm.scm,v 1.1 1990/05/07 04:15:46 jinx Rel $
+$MC68020-Header: rgspcm.scm,v 4.1 87/12/30 07:05:38 GMT cph Exp $
+
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Generation: Special primitive combinations. MIPS version.
+
+(declare (usual-integrations))
+\f
+(define (define-special-primitive-handler name handler)
+ (let ((primitive (make-primitive-procedure name true)))
+ (let ((entry (assq primitive special-primitive-handlers)))
+ (if entry
+ (set-cdr! entry handler)
+ (set! special-primitive-handlers
+ (cons (cons primitive handler)
+ special-primitive-handlers)))))
+ name)
+
+(define (special-primitive-handler primitive)
+ (let ((entry (assq primitive special-primitive-handlers)))
+ (and entry
+ (cdr entry))))
+
+(define special-primitive-handlers
+ '())
+
+(define (define-special-primitive/standard primitive)
+ (define-special-primitive-handler primitive
+ rtl:make-invocation:special-primitive))
+
+(define-special-primitive/standard '&+)
+(define-special-primitive/standard '&-)
+;; (define-special-primitive/standard '&*)
+(define-special-primitive/standard '&/)
+(define-special-primitive/standard '&=)
+(define-special-primitive/standard '&<)
+(define-special-primitive/standard '&>)
+(define-special-primitive/standard '1+)
+(define-special-primitive/standard '-1+)
+(define-special-primitive/standard 'zero?)
+(define-special-primitive/standard 'positive?)
+(define-special-primitive/standard 'negative?)
+
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules1.scm,v 1.1 1990/05/07 04:16:03 jinx Exp $
+$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $
+
+Copyright (c) 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Data Transfers
+
+(declare (usual-integrations))
+\f
+;;;; Simple Operations
+
+;;; All assignments to pseudo registers are required to delete the
+;;; dead registers BEFORE performing the assignment. However, it is
+;;; necessary to derive the effective address of the source
+;;; expression(s) before deleting the dead registers. Otherwise any
+;;; source expression containing dead registers might refer to aliases
+;;; which have been reused.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
+ (standard-move-to-target! source target)
+ (LAP))
+
+(define-rule statement
+ ;; tag the contents of a register
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (let* ((type (standard-move-to-temporary! type))
+ (target (standard-move-to-target! datum target)))
+ (LAP (SLL ,type ,type ,(- 32 scheme-type-width))
+ (AND ,target ,target ,regnum:address-mask)
+ (OR ,target ,type ,target))))
+
+(define-rule statement
+ ;; tag the contents of a register
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
+ (let ((target (standard-move-to-target! source target)))
+ (deposit-type type target)))
+
+(define-rule statement
+ ;; extract the type part of a register's contents
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (standard-unary-conversion source target object->type))
+
+(define-rule statement
+ ;; extract the datum part of a register's contents
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+ (standard-unary-conversion source target object->datum))
+
+(define-rule statement
+ ;; convert the contents of a register to an address
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (let ((target (standard-move-to-target! source target)))
+ (object->address target)))
+
+(define-rule statement
+ ;; add a constant to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (add-immediate (* 4 offset) source target))))
+
+(define-rule statement
+ ;; read an object from memory
+ (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
+ (standard-unary-conversion address target
+ (lambda (address target)
+ (LAP (LW ,target (OFFSET ,(* 4 offset) ,address))
+ (NOP)))))
+
+(define-rule statement
+ ;; pop an object off the stack
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 3) 1))
+ (LAP (LW ,(standard-target! target) (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)))
+\f
+;;;; Loading of Constants
+
+(define-rule statement
+ ;; load a machine constant
+ (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
+ (load-immediate source (standard-target! target)))
+
+(define-rule statement
+ ;; load a Scheme constant
+ (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
+ (load-constant source (standard-target! target) #T))
+
+(define-rule statement
+ ;; load the type part of a Scheme constant
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
+ (load-non-pointer 0 (object-type constant) (standard-target! target)))
+
+(define-rule statement
+ ;; load the datum part of a Scheme constant
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
+ (QUALIFIER (non-pointer-object? constant))
+ (load-non-pointer 0
+ (careful-object-datum constant)
+ (standard-target! target)))
+
+(define-rule statement
+ ;; load a synthesized constant
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (load-non-pointer type datum (standard-target! target)))
+
+(define-rule statement
+ ;; load the address of a variable reference cache
+ (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+ (LAP
+ ,@(load-pc-relative (free-reference-label name)
+ (standard-target! target))
+ (NOP)))
+
+(define-rule statement
+ ;; load the address of an assignment cache
+ (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
+ (LAP
+ ,@(load-pc-relative (free-assignment-label name)
+ (standard-target! target))
+ (NOP)))
+
+(define-rule statement
+ ;; load the address of a procedure's entry point
+ (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
+ (load-pc-relative-address label (standard-target! target)))
+
+(define-rule statement
+ ;; load the address of a continuation
+ (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
+ (load-pc-relative-address label (standard-target! target)))
+
+;;; Spectrum optimizations converted to MIPS
+
+(define (load-entry label target)
+ (let ((target (standard-target! target)))
+ (LAP ,@(load-pc-relative-address label target)
+ ,@(address->entry target))))
+
+(define-rule statement
+ ;; load a procedure object
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:PROCEDURE (? label))))
+ (QUALIFIER (= type (ucode-type compiled-entry)))
+ (load-entry label target))
+
+(define-rule statement
+ ;; load a return address object
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:CONTINUATION (? label))))
+ (QUALIFIER (= type (ucode-type compiled-entry)))
+ (load-entry label target))
+\f
+;;;; Transfers to Memory
+
+(define-rule statement
+ ;; store an object in memory
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (? source register-expression))
+ (QUALIFIER (word-register? source))
+ (LAP (SW ,(standard-source! source)
+ (OFFSET ,(* 4 offset) ,(standard-source! address)))))
+
+(define-rule statement
+ ;; Push an object register on the heap
+ (ASSIGN (POST-INCREMENT (REGISTER 9) 1)
+ (? source register-expression))
+ (QUALIFIER (word-register? source))
+ (LAP (SW ,(standard-source! source) (OFFSET 0 ,regnum:free))
+ (ADDI ,regnum:free ,regnum:free 4)))
+
+(define-rule statement
+ ;; Push an object register on the stack
+ (ASSIGN (PRE-INCREMENT (REGISTER 3) -1)
+ (? source register-expression))
+ (QUALIFIER (word-register? source))
+ (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
+ (SW ,(standard-source! source)
+ (OFFSET 0 ,regnum:stack-pointer))))
+
+;; Cheaper, common patterns.
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (MACHINE-CONSTANT 0))
+ (LAP (SW 0 (OFFSET ,(* 4 offset) ,(standard-source! address)))))
+
+(define-rule statement
+ ; Push NIL (or whatever is represented by a machine 0) on heap
+ (ASSIGN (POST-INCREMENT (REGISTER 9) 1) (MACHINE-CONSTANT 0))
+ (LAP (SW 0 (OFFSET 0 ,regnum:free))
+ (ADDI ,regnum:free ,regnum:free 4)))
+
+(define-rule statement
+ ; Ditto, but on stack
+ (ASSIGN (PRE-INCREMENT (REGISTER 3) -1) (MACHINE-CONSTANT 0))
+ (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
+ (SW 0 (OFFSET 0 ,regnum:stack-pointer))))
+\f
+;;;; CHAR->ASCII/BYTE-OFFSET
+
+(define-rule statement
+ ;; load char object from memory and convert to ASCII byte
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
+ (standard-unary-conversion address target
+ (lambda (address target)
+ (LAP (LBU ,target (OFFSET ,(* 4 offset) ,address))
+ (NOP)))))
+
+(define-rule statement
+ ;; load ASCII byte from memory
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET (REGISTER (? address)) (? offset)))
+ (standard-unary-conversion address target
+ (lambda (address target)
+ (LAP (LBU ,target (OFFSET ,offset ,address))
+ (NOP)))))
+
+(define-rule statement
+ ;; convert char object to ASCII byte
+ ;; Missing optimization: If source is home and this is the last
+ ;; reference (it is dead afterwards), an LB could be done instead
+ ;; of an LW followed by an object->datum. This is unlikely since
+ ;; the value will be home only if we've spilled it, which happens
+ ;; rarely.
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (REGISTER (? source))))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (LAP (SLL ,target ,source 24)
+ (SRL ,target ,target 24)))))
+
+(define-rule statement
+ ;; store null byte in memory
+ (ASSIGN (BYTE-OFFSET (REGISTER (? source)) (? offset))
+ (CHAR->ASCII (CONSTANT #\NUL)))
+ (LAP (SB 0 (OFFSET ,offset ,(standard-source! source)))))
+
+(define-rule statement
+ ;; store ASCII byte in memory
+ (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (REGISTER (? source)))
+ (LAP (SB ,(standard-source! source)
+ (OFFSET ,offset ,(standard-source! address)))))
+
+(define-rule statement
+ ;; convert char object to ASCII byte and store it in memory
+ ;; register + byte offset <- contents of register (clear top bits)
+ (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (CHAR->ASCII (REGISTER (? source))))
+ (LAP (SB ,(standard-source! source)
+ (OFFSET ,offset ,(standard-source! address)))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules2.scm,v 1.1 1990/05/07 04:16:16 jinx Rel $
+$MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Predicates
+
+(declare (usual-integrations))
+\f
+(define-rule predicate
+ ;; test for two registers EQ?
+ (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
+ (compare '= (standard-source! source1) (standard-source! source2)))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
+ (eq-test/constant*register constant register))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
+ (eq-test/constant*register constant register))
+
+(define (eq-test/constant*register constant source)
+ (let ((source (standard-source! source)))
+ (if (non-pointer-object? constant)
+ (compare-immediate '= (non-pointer->literal constant) source)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-constant constant temp #T)
+ ,@(compare '= temp source))))))
+
+(define-rule predicate
+ ;; test for register EQ? to synthesized constant
+ (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (REGISTER (? register)))
+ (eq-test/synthesized-constant*register type datum register))
+
+(define-rule predicate
+ ;; test for register EQ? to synthesized constant
+ (EQ-TEST (REGISTER (? register))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (eq-test/synthesized-constant*register type datum register))
+
+(define (eq-test/synthesized-constant*register type datum source)
+ (compare-immediate '=
+ (make-non-pointer-literal type datum)
+ (standard-source! source)))
+
+(define-rule predicate
+ ;; Branch if virtual register contains the specified type number
+ (TYPE-TEST (REGISTER (? register)) (? type))
+ (compare-immediate '= type (standard-source! register)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules3.scm,v 1.1 1990/05/07 04:16:34 jinx Exp $
+$MC68020-Header: rules3.scm,v 4.23 90/01/18 22:44:09 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Invocations and Entries
+
+(declare (usual-integrations))
+\f
+;;;; Invocations
+
+(define-rule statement
+ (POP-RETURN)
+ (pop-return))
+
+(define (pop-return)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(clear-map!)
+ (LW ,temp (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
+ ,@(object->address temp)
+ (JR ,temp)
+ (NOP)))) ; DELAY SLOT
+
+(define-rule statement
+ (INVOCATION:APPLY (? frame-size) (? continuation))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ ,@(load-immediate frame-size regnum:third-arg)
+ (LW ,regnum:second-arg (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
+ ,@(invoke-interface code:compiler-apply)))
+
+(define-rule statement
+ (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+ frame-size continuation ;ignore
+ (LAP ,@(clear-map!)
+ (BGEZ 0 (@PCR ,label))
+ (NOP))) ; DELAY SLOT
+
+(define-rule statement
+ (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
+ frame-size continuation ;ignore
+ ;; It expects the procedure at the top of the stack
+ (pop-return))
+
+(define-rule statement
+ (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ ,@(load-immediate number-pushed regnum:third-arg)
+ ,@(load-pc-relative-address label regnum:second-arg)
+ ,@(invoke-interface code:compiler-lexpr-apply)))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
+ continuation ;ignore
+ ;; Destination address is at TOS; pop it into second-arg
+ (LAP ,@(clear-map!)
+ (LW ,regnum:second-arg (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
+ ,@(load-immediate number-pushed regnum:third-arg)
+ ,@(object->address regnum:second-arg)
+ ,@(invoke-interface code:compiler-lexpr-apply)))
+
+(define-rule statement
+ (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ (BGEZ 0 (@PCR ,(free-uuo-link-label name frame-size)))
+ (NOP))) ; DELAY SLOT
+
+(define-rule statement
+ (INVOCATION:CACHE-REFERENCE (? frame-size)
+ (? continuation)
+ (? extension register-expression))
+ continuation ;ignore
+ (LAP ,@(load-interface-args! extension false false false)
+ ,@(load-immediate frame-size regnum:fourth-arg)
+ ,@(load-pc-relative-address *block-label* regnum:third-arg)
+ ,@(invoke-interface code:compiler-cache-reference-apply)))
+\f
+(define-rule statement
+ (INVOCATION:LOOKUP (? frame-size)
+ (? continuation)
+ (? environment register-expression)
+ (? name))
+ continuation ;ignore
+ (LAP ,@(load-interface-args! environment false false false)
+ ,(load-constant name regnum:third-arg)
+ ,(load-immediate frame-size regnum:fourth-arg)
+ ,@(invoke-interface code:compiler-lookup-apply)))
+
+(define-rule statement
+ (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
+ continuation ;ignore
+ (if (eq? primitive compiled-error-procedure)
+ (LAP ,@(clear-map!)
+ ,@(load-immediate frame-size regnum:second-arg)
+ ,@(invoke-interface code:compiler-error))
+ (LAP ,@(clear-map!)
+ ,@(load-pc-relative (constant->label primitive)
+ regnum:second-arg)
+ ,@(let ((arity (primitive-procedure-arity primitive)))
+ (cond ((not (negative? arity))
+ (invoke-interface code:compiler-primitive-apply))
+ ((= arity -1)
+ (LAP ,@(load-immediate (-1+ frame-size)
+ ,regnum:assembler-temp)
+
+ (SW ,regnum:assembler-temp
+ ,reg:lexpr-primitive-arity)
+ ,@(invoke-interface
+ code:compiler-primitive-lexpr-apply)))
+ (else
+ ;; Unknown primitive arity. Go through apply.
+ (LAP ,@(load-immediate frame-size regnum:third-arg)
+ ,@(invoke-interface code:compiler-apply))))))))
+
+(let-syntax
+ ((define-special-primitive-invocation
+ (macro (name)
+ `(define-rule statement
+ (INVOCATION:SPECIAL-PRIMITIVE
+ (? frame-size)
+ (? continuation)
+ ,(make-primitive-procedure name true))
+ frame-size continuation
+ ,(list 'LAP
+ (list 'UNQUOTE-SPLICING '(clear-map!))
+ (list 'UNQUOTE-SPLICING
+ `(INVOKE-INTERFACE ,(symbol-append 'CODE:COMPILER-
+ name))))))))
+ (define-special-primitive-invocation &+)
+ (define-special-primitive-invocation &-)
+ (define-special-primitive-invocation &*)
+ (define-special-primitive-invocation &/)
+ (define-special-primitive-invocation &=)
+ (define-special-primitive-invocation &<)
+ (define-special-primitive-invocation &>)
+ (define-special-primitive-invocation 1+)
+ (define-special-primitive-invocation -1+)
+ (define-special-primitive-invocation zero?)
+ (define-special-primitive-invocation positive?)
+ (define-special-primitive-invocation negative?))
+\f
+;;;; Invocation Prefixes
+
+;;; MOVE-FRAME-UP size address
+;;;
+;;; Moves up the last <size> words of the stack so that the first of
+;;; these words is at location <address>, and resets the stack pointer
+;;; to the last of these words. That is, it pops off all the words
+;;; between <address> and TOS+/-<size>.
+
+(define-rule statement
+ ;; Move up 0 words back to top of stack : a No-Op
+ (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 3))
+ (LAP))
+
+(define-rule statement
+ ;; Move <frame-size> words back to dynamic link marker
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 11))
+ (generate/move-frame-up frame-size
+ (lambda (reg) (LAP (ADD ,reg 0 ,regnum:dynamic-link)))))
+
+(define-rule statement
+ ;; Move <frame-size> words back to SP+offset
+ (INVOCATION-PREFIX:MOVE-FRAME-UP
+ (? frame-size) (OFFSET-ADDRESS (REGISTER 3) (? offset)))
+ (let ((how-far (* 4 (- offset frame-size))))
+ (cond ((zero? how-far)
+ (LAP))
+ ((negative? how-far)
+ (error "invocation-prefix:move-frame-up: bad specs"
+ frame-size offset))
+ ((zero? frame-size)
+ (add-immediate how-far ,regnum:stack-pointer
+ ,regnum:stack-pointer))
+ ((= frame-size 1)
+ (let ((temp (standard-temporary!)))
+ (LAP (LW ,temp (OFFSET ,how-far ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer
+ ,regnum:stack-pointer ,how-far)
+ (STW ,temp (OFFSET 0 ,regnum:stack-pointer)))))
+ ((= frame-size 2)
+ (let ((temp1 (standard-temporary!))
+ (temp2 (standard-temporary!)))
+ (LAP (LW ,temp1 (OFFSET 0 ,regnum:stack-pointer))
+ (LW ,temp2 (OFFSET 4 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far)
+ (SW ,temp1 (OFFSET 0 ,regnum:stack-pointer))
+ (SW ,temp2 (OFFSET 4 ,regnum:stack-pointer)))))
+ (else
+ (generate/move-frame-up frame-size
+ (lambda (reg)
+ (add-immediate
+ (* 4 offset) ,regnum:stack-pointer reg)))))))
+
+(define-rule statement
+ ;; Move <frame-size> words back to base virtual register + offset
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (? offset)))
+ (generate/move-frame-up frame-size
+ (lambda (reg)
+ (add-immediate (* 4 offset) (standard-source! base) reg))))
+\f
+;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
+;;; and <current dynamic link> as arguments. They pop the stack by
+;;; removing the lesser of the amount needed to move the stack pointer
+;;; back to the <new frame end> or <current dynamic link>. The last
+;;; <frame-size> words on the stack (the stack frame for the procedure
+;;; about to be called) are then put back onto the newly adjusted
+;;; stack.
+
+(define-rule statement
+ (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
+ (REGISTER (? source))
+ (REGISTER 11))
+ (if (and (zero? frame-size)
+ (= source regnum:stack-pointer))
+ (LAP)
+ (let ((env-reg (standard-move-to-temporary! source)))
+ (LAP (SLTU ,regnum:assembler-temp
+ ,env-reg ,regnum:dynamic-link)
+ (BNE 0 ,regnum:assembler-temp (@PCO 8))
+ (NOP) ; +0: DELAY SLOT
+ (ADD ,env-reg 0 ; +4: Skipped instruction
+ ,regnum:dynamic-link)
+ ,@(generate/move-frame-up* ; +8: here
+ frame-size env-reg)))))
+
+(define (generate/move-frame-up frame-size destination-generator)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(destination-generator temp)
+ ,@(generate/move-frame-up* frame-size temp))))
+
+(define (generate/move-frame-up* frame-size destination)
+ ;; Destination is guaranteed to be a machine register number; that
+ ;; register has the destination base address for the frame. The stack
+ ;; pointer is reset to the top end of the copied area.
+ (LAP ,@(case frame-size
+ ((0)
+ (LAP))
+ ((1)
+ (let ((temp (standard-temporary!)))
+ (LAP (LW ,temp (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,destination ,destination -4)
+ (SW ,temp (OFFSET 0 ,destination)))))
+ (else
+ (generate/move-frame-up** frame-size destination)))
+ (ADD ,regnum:stack-pointer 0 ,destination)))
+
+(define (generate/move-frame-up** frame-size dest)
+ (let ((from (standard-temporary!))
+ (temp1 (standard-temporary!))
+ (temp2 (standard-temporary!)))
+ (LAP ,@(add-immediate (* 4 frame-size) regnum:stack-pointer from)
+ ,@(if (<= frame-size 3)
+ ;; This code can handle any number > 1 (handled above),
+ ;; but we restrict it to 3 for space reasons.
+ (let loop ((n frame-size))
+ (case n
+ ((0)
+ (LAP))
+ ((3)
+ (let ((temp3 (standard-temporary!)))
+ (LAP (LW ,temp1 (OFFSET -4 ,from))
+ (LW ,temp2 (OFFSET -8 ,from))
+ (LW ,temp3 (OFFSET -12 ,from))
+ (ADDI ,from ,from -12)
+ (SW ,temp1 (OFFSET -4 ,dest))
+ (SW ,temp2 (OFFSET -8 ,dest))
+ (SW ,temp3 (OFFSET -12 ,dest))
+ (ADDI ,dest ,dest -12))))
+ (else
+ (LAP (LW ,temp1 (OFFSET -4 ,from))
+ (LW ,temp2 (OFFSET -8 ,from))
+ (ADDI ,from ,from -8)
+ (SW ,temp1 (OFFSET -4 ,dest))
+ (SW ,temp2 (OFFSET -8 ,dest))
+ (ADDI ,dest ,dest -8)
+ ,@(loop (- n 2))))))
+ (LAP ,@(load-immediate frame-size temp2)
+ (LW ,temp1 (OFFSET -4 ,from)) ; -20
+ (ADDI ,from ,from -4) ; -16
+ (ADDI ,temp2 ,temp2 -1) ; -12
+ (ADDI ,dest ,dest -4) ; -8
+ (BNE ,temp2 0 (@PCO -20)) ; -4
+ (SW ,temp1 (OFFSET 0 ,dest)))))))
+\f
+;;;; External Labels
+
+(define (make-external-label code label)
+ (set! *external-labels* (cons label *external-labels*))
+ (LAP (EXTERNAL-LABEL ,code (@PCR ,label))
+ (LABEL ,label)))
+
+;;; Entry point types
+
+(define-integrable (make-code-word min max)
+ (+ (* #x100 min) max))
+
+(define (make-procedure-code-word min max)
+ ;; The "min" byte must be less than #x80; the "max" byte may not
+ ;; equal #x80 but can take on any other value.
+ (if (or (negative? min) (>= min #x80))
+ (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
+ (if (>= (abs max) #x80)
+ (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
+ (make-code-word min (if (negative? max) (+ #x100 max) max)))
+
+(define expression-code-word
+ (make-code-word #xff #xff))
+
+(define internal-entry-code-word
+ (make-code-word #xff #xfe))
+
+(define (continuation-code-word label)
+ (let ((offset
+ (if label
+ (rtl-continuation/next-continuation-offset (label->object label))
+ 0)))
+ (cond ((not offset)
+ (make-code-word #xff #xfc))
+ ((< offset #x2000)
+ ;; This uses up through (#xff #xdf).
+ (let ((qr (integer-divide offset #x80)))
+ (make-code-word (+ #x80 (integer-divide-remainder qr))
+ (+ #x80 (integer-divide-quotient qr)))))
+ (else
+ (error "Unable to encode continuation offset" offset)))))
+\f
+;;;; Procedure headers
+
+;;; The following calls MUST appear as the first thing at the entry
+;;; point of a procedure. They assume that the register map is clear
+;;; and that no register contains anything of value.
+
+;;; **** The only reason that this is true is that no register is live
+;;; across calls. If that were not true, then we would have to save
+;;; any such registers on the stack so that they would be GC'ed
+;;; appropriately.
+;;;
+;;; **** This is not strictly true: the dynamic link register may
+;;; contain a valid dynamic link, but the gc handler determines that
+;;; and saves it as appropriate.
+
+(define (simple-procedure-header code-word label code)
+ (let ((gc-label (generate-label)))
+ (LAP (LABEL ,gc-label)
+ ,@(link-to-interface code)
+ ,@(make-external-label code-word label)
+ ,@(interrupt-check gc-label))))
+
+(define (dlink-procedure-header code-word label)
+ (let ((gc-label (generate-label)))
+ (LAP (LABEL ,gc-label)
+ (ADD ,regnum:third-arg 0 ,regnum:dynamic-link)
+ ,@(link-to-interface code:compiler-interrupt-dlink)
+ ,@(make-external-label code-word label)
+ ,@(interrupt-check gc-label))))
+
+(define (interrupt-check gc-label)
+ (LAP (SLT ,regnum:assembler-temp ,regnum:memtop ,regnum:free)
+ (BNE ,regnum:assembler-temp 0 (@PCR ,gc-label))
+ (LW ,regnum:memtop ,reg:memtop)))
+
+(define-rule statement
+ (CONTINUATION-ENTRY (? internal-label))
+ (make-external-label (continuation-code-word internal-label)
+ internal-label))
+
+(define-rule statement
+ (CONTINUATION-HEADER (? internal-label))
+ (simple-procedure-header (continuation-code-word internal-label)
+ internal-label
+ code:compiler-interrupt-continuation))
+
+(define-rule statement
+ (IC-PROCEDURE-HEADER (? internal-label))
+ (let ((procedure (label->object internal-label)))
+ (let ((external-label (rtl-procedure/external-label procedure)))
+ (LAP (ENTRY-POINT ,external-label)
+ (EQUATE ,external-label ,internal-label)
+ ,@(simple-procedure-header expression-code-word
+ internal-label
+ code:compiler-interrupt-ic-procedure)))))
+
+(define-rule statement
+ (OPEN-PROCEDURE-HEADER (? internal-label))
+ (let ((rtl-proc (label->object internal-label)))
+ (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
+ ,@((if (rtl-procedure/dynamic-link? rtl-proc)
+ dlink-procedure-header
+ (lambda (code-word label)
+ (simple-procedure-header code-word label
+ code:compiler-interrupt-procedure)))
+ internal-entry-code-word
+ internal-label))))
+
+(define-rule statement
+ (PROCEDURE-HEADER (? internal-label) (? min) (? max))
+ (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
+ ,internal-label)
+ ,@(simple-procedure-header (make-procedure-code-word min max)
+ internal-label
+ code:compiler-interrupt-procedure)))
+\f
+;;;; Closures.
+
+;; Magic for compiled entries.
+
+(define-integrable (address->entry register)
+ (deposit-type (ucode-type compiled-entry) register))
+
+(define-rule statement
+ (CLOSURE-HEADER (? internal-label))
+ (let ((procedure (label->object internal-label)))
+ (let ((gc-label (generate-label))
+ (external-label (rtl-procedure/external-label procedure)))
+ (LAP (LABEL ,gc-label)
+ ,@(invoke-interface code:compiler-interrupt-closure)
+ ,@(make-external-label internal-entry-code-word external-label)
+ ; Code below here corresponds to code and count in cmpint2.h
+ ,@(address->entry regnum:linkage)
+ (SW ,regnum:linkage (OFFSET -4 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
+ (LABEL ,internal-label)
+ ,@(interrupt-check gc-label)))))
+
+(define (cons-closure target label min max size ->entry?)
+ (let ((flush-reg (clear-registers! regnum:interface-index)))
+ (need-register! regnum:interface-index)
+ (let ((dest (standard-target! target)))
+ ;; Note: dest is used as a temporary before the JALR
+ ;; instruction, and is written immediately afterwards.
+ ;; The interface (scheme_to_interface-88) expects:
+ ;; 1: size of closure = size+3
+ ;; 4: offset to destination label
+ ;; 25: GC offset and arity information
+ (LAP ,@flush-reg
+ ,@(load-immediate (+ size 3) 1)
+ (LUI 25 4)
+ (PC-RELATIVE-OFFSET 4 16
+ ,(rtl-procedure/external-label (label->object label)))
+ (ADDI ,dest ,regnum:scheme-to-interface -88) ; + 4
+ (JALR ,regnum:linkage ,dest) ; + 8
+ (ORI 25 25 ,(make-procedure-code-word min max)) ; +12
+ ,@(add-immediate (* 4 (- (+ size 2))) ; +16
+ regnum:free dest)
+ ,@(if ->entry? (address->entry dest) (LAP))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+ (? min) (? max) (? size))))
+ (QUALIFIER (= type (ucode-type compiled-entry)))
+ (cons-closure target procedure-label min max size true))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+ (? min) (? max) (? size)))
+ (QUALIFIER (= type (ucode-type compiled-entry)))
+ (cons-closure target procedure-label min max size false))
+\f
+;;;; Entry Header
+;;; This is invoked by the top level of the LAP generator.
+
+(define (generate/quotation-header environment-label free-ref-label n-sections)
+ ;; Calls the linker
+ ;; On MIPS, regnum:first-arg is used as a temporary here since
+ ;; load-pc-relative-address uses the assembler temporary.
+ (LAP
+ ; Grab interp's env. and store in code block at environment-label
+ (LW ,regnum:first-arg ,reg:environment)
+ ,@(load-pc-relative-address environment-label regnum:second-arg)
+ (SW ,regnum:first-arg (OFFSET 0 ,regnum:second-arg))
+ ; Now invoke the linker (arg. 1 is return address, supplied by interface)
+ ,@(load-pc-relative-address *block-label* regnum:third-arg)
+ ,@(load-pc-relative-address free-ref-label regnum:fourth-arg)
+ ,@(load-immediate n-sections regnum:first-arg)
+ (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer))
+ ,@(link-to-interface code:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))
+
+(define (generate/remote-link code-block-label
+ environment-offset
+ free-ref-offset
+ n-sections)
+ ;; Link all of the top level procedures within the file
+ (LAP ,@(load-pc-relative code-block-label regnum:third-arg)
+ (LW ,regnum:assembler-temp ,reg:environment)
+ ,@(object->address regnum:third-arg)
+ ,@(add-immediate environment-offset regnum:third-arg
+ regnum:second-arg)
+ (SW ,regnum:assembler-temp (OFFSET 0 ,regnum:second-arg))
+ ,@(add-immediate free-ref-offset regnum:third-arg regnum:fourth-arg)
+ ,@(load-immediate n-sections regnum:first-arg)
+ (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer))
+ ,@(link-to-interface code:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))
+\f
+(define (generate/constants-block constants references assignments uuo-links)
+ (let ((constant-info
+ (declare-constants 0 (transmogrifly uuo-links)
+ (declare-constants 1 references
+ (declare-constants 2 assignments
+ (declare-constants false constants
+ (cons false (LAP))))))))
+ (let ((free-ref-label (car constant-info))
+ (constants-code (cdr constant-info))
+ (debugging-information-label (allocate-constant-label))
+ (environment-label (allocate-constant-label))
+ (n-sections
+ (+ (if (null? uuo-links) 0 1)
+ (if (null? references) 0 1)
+ (if (null? assignments) 0 1))))
+ (values
+ (LAP ,@constants-code
+ ;; Place holder for the debugging info filename
+ (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
+ ;; Place holder for the load time environment if needed
+ (SCHEME-OBJECT ,environment-label
+ ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
+ environment-label
+ free-ref-label
+ n-sections))))
+
+(define (declare-constants tag constants info)
+ (define (inner constants)
+ (if (null? constants)
+ (cdr info)
+ (let ((entry (car constants)))
+ (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
+ ,@(inner (cdr constants))))))
+ (if (and tag (not (null? constants)))
+ (let ((label (allocate-constant-label)))
+ (cons label
+ (inner
+ `((,(let ((datum (length constants)))
+ (if (> datum #xffff)
+ (error "datum too large" datum))
+ (+ (* tag #x10000) datum))
+ . ,label)
+ ,@constants))))
+ (cons (car info) (inner constants))))
+
+(define (transmogrifly uuos)
+ (define (inner name assoc)
+ (if (null? assoc)
+ (transmogrifly (cdr uuos))
+ ; produces ((name . label) (0 . label) ... (frame-size . label) ...)
+ ; where the (0 . label) is repeated to fill out the size required
+ ; as specified in machin.scm
+ `((,name . ,(cdar assoc)) ; uuo-label
+ ,@(let loop ((count (max 0 (- execute-cache-size 2))))
+ (if (= count 0)
+ '()
+ (cons `(0 . ,(allocate-constant-label))
+ (loop (- count 1)))))
+ (,(caar assoc) . ; frame-size
+ ,(allocate-constant-label))
+ ,@(inner name (cdr assoc)))))
+ (if (null? uuos)
+ '()
+ (inner (caar uuos) (cdar uuos)))) ; caar is name, cdar is alist of frame sizes
+\f
+;;; Local Variables: ***
+;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
+;;; End: ***
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules4.scm,v 1.1 1990/05/07 04:16:57 jinx Rel $
+$MC68020-Header: rules4.scm,v 4.11 90/01/20 07:26:13 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Interpreter Calls
+
+(declare (usual-integrations))
+\f
+;;;; Interpreter Calls
+
+(define-rule statement
+ (INTERPRETER-CALL:ACCESS (? environment register-expression) (? name))
+ (lookup-call code:compiler-access environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:LOOKUP (? environment register-expression)
+ (? name)
+ (? safe?))
+ (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
+ environment
+ name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNASSIGNED? (? environment register-expression) (? name))
+ (lookup-call code:compiler-unassigned? environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNBOUND? (? environment register-expression) (? name))
+ (lookup-call code:compiler-unbound? environment name))
+
+(define (lookup-call code environment name)
+ (LAP ,@(load-interface-args! false environment false false)
+ ,@(load-constant name regnum:third-arg)
+ ,@(link-to-interface code)))
+
+(define-rule statement
+ (INTERPRETER-CALL:DEFINE (? environment register-expression)
+ (? name)
+ (? value register-expression))
+ (assignment-call code:compiler-define environment name value))
+
+(define-rule statement
+ (INTERPRETER-CALL:SET! (? environment register-expression)
+ (? name)
+ (? value register-expression))
+ (assignment-call code:compiler-set! environment name value))
+
+(define (assignment-call code environment name value)
+ (LAP ,@(load-interface-args! false environment false value)
+ ,@(load-constant name regnum:third-arg)
+ ,@(link-to-interface code)))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-REFERENCE (REGISTER (? extension)) (? safe?))
+ (LAP ,@(load-interface-args! false extension false false)
+ ,@(link-to-interface
+ (if safe?
+ code:compiler-safe-reference-trap
+ code:compiler-reference-trap))))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-ASSIGNMENT (REGISTER (? extension))
+ (? value register-expression))
+ (LAP ,@(load-interface-args! false extension value false)
+ ,@(link-to-interface code:compiler-assignment-trap)))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-UNASSIGNED? (REGISTER (? extension)))
+ (LAP ,@(load-interface-args! false extension false false)
+ ,@(link-to-interface code:compiler-unassigned?-trap)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulfix.scm,v 1.1 1990/05/07 04:17:20 jinx Rel $
+$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $
+
+Copyright (c) 1989, 1990 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 Rules
+
+(declare (usual-integrations))
+\f
+;;;; Conversions
+
+(define-rule statement
+ ;; convert a fixnum object to a "fixnum integer"
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+ (standard-unary-conversion source target object->fixnum))
+
+(define-rule statement
+ ;; load a fixnum constant as a "fixnum integer"
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (load-fixnum-constant constant (standard-target! target)))
+
+(define-rule statement
+ ;; convert a memory address to a "fixnum integer"
+ (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
+ (standard-unary-conversion source target address->fixnum))
+
+(define-rule statement
+ ;; convert an object's address to a "fixnum integer"
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
+ (standard-unary-conversion source target object->fixnum))
+
+(define-rule statement
+ ;; convert a "fixnum integer" to a fixnum object
+ (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
+ (standard-unary-conversion source target fixnum->object))
+
+(define-rule statement
+ ;; convert a "fixnum integer" to a memory address
+ (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
+ (standard-unary-conversion source target fixnum->address))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (CONSTANT 4))
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ #F))
+ (standard-unary-conversion source target object->index-fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ (OBJECT->FIXNUM (CONSTANT 4))
+ #F))
+ (standard-unary-conversion source target object->index-fixnum))
+
+;; This is a patch for the time being. Probably only one of these pairs
+;; of rules is needed.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (CONSTANT 4))
+ (REGISTER (? source))
+ #F))
+ (standard-unary-conversion source target fixnum->index-fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT 4))
+ #F))
+ (standard-unary-conversion source target fixnum->index-fixnum))
+
+; "Fixnum" in this context means an integer left shifted 6 bits
+
+(define-integrable (fixnum->index-fixnum src tgt)
+ ; Shift left 2 bits
+ (LAP (SLL ,tgt ,src 2)))
+
+(define-integrable (object->fixnum src tgt)
+ ; Shift left by scheme-type-width
+ (LAP (SLL ,tgt ,src ,scheme-type-width)))
+
+(define-integrable (object->index-fixnum src tgt)
+ ; Shift left by scheme-type-width+2
+ (LAP (SLL ,tgt ,src ,(+ scheme-type-width 2))))
+
+(define-integrable (address->fixnum src tgt)
+ ; Strip off type bits, just like object->fixnum
+ (LAP (SLL ,tgt ,src ,scheme-type-width)))
+
+(define-integrable (fixnum->object src tgt)
+ ; Move right by type code width and put on fixnum type code
+ (LAP (SRL ,tgt ,src ,scheme-type-width)
+ ,@(put-type (ucode-type fixnum) tgt)))
+
+(define (fixnum->address src tgt)
+ ; Move right by type code width and put in address bits
+ (LAP (SRL ,tgt ,src ,scheme-type-width)
+ ,@(put-address-bits tgt)))
+
+(define (load-fixnum-constant constant target)
+ (load-immediate (* constant fixnum-1) target))
+
+(define-integrable fixnum-1
+ (expt 2 scheme-type-width))
+
+(define-integrable -fixnum-1
+ (- fixnum-1))
+\f
+;;;; Arithmetic Operations
+
+(define-rule statement
+ ;; execute a unary fixnum operation
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-1-ARG (? operation)
+ (REGISTER (? source))
+ (? overflow?)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ ((fixnum-1-arg/operator operation) target source overflow?))))
+
+(define (fixnum-1-arg/operator operation)
+ (lookup-arithmetic-method operation fixnum-methods/1-arg))
+
+(define fixnum-methods/1-arg
+ (list 'FIXNUM-METHODS/1-ARG))
+
+; Assumption: overflow sets or clears register regnum:assembler-temp,
+; and this code is followed immediately by a branch on overflow
+
+(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (tgt src overflow?)
+ (if overflow?
+ (let ((label-1 (generate-label))
+ (label-2 (generate-label)))
+ (LAP (BLTZ ,src (@PCR ,label-1))
+ (ADDI ,regnum:assembler-temp 0 0)
+ (ADDIU ,regnum:first-arg ,src ,fixnum-1)
+ (BGEZ ,regnum:assembler-temp (@PCR ,label-2))
+ (ADDIU ,tgt ,src ,fixnum-1)
+ (ADDI ,regnum:assembler-temp 0 1)
+ (LABEL ,label-1)
+ (ADDIU ,tgt ,src ,fixnum-1)
+ (LABEL ,label-2)))
+ (LAP (ADDIU ,tgt ,src ,fixnum-1)))))
+
+(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM
+ fixnum-methods/1-arg
+ (lambda (tgt src overflow?)
+ (if overflow?
+ (let ((label-1 (generate-label))
+ (label-2 (generate-label)))
+ (LAP (BGEZ ,src (@PCR ,label-1)) ; Can't overflow if >0
+ (ADDI ,regnum:assembler-temp 0 0) ; Clear o'flow flag
+ (ADDIU ,regnum:assembler-temp ,src ,-fixnum-1) ; Do subtraction into temp
+ (BGEZ ,regnum:assembler-temp (@PCR ,label-2)) ; Overflow? -> label-2
+ (ADDIU ,regnum:assembler-temp 0 1) ; Set overflow flag
+ (ADDI ,regnum:assembler-temp 0 0) ; Clear overflow flag
+ (LABEL ,label-1)
+ (ADDIU ,tgt ,src ,-fixnum-1) ; Do subtraction
+ (LABEL ,label-2)))
+ (LAP (ADDIU ,tgt ,src ,-fixnum-1)))))
+
+(define-rule statement
+ ;; execute a binary fixnum operation
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ (standard-binary-conversion source1 source2 target
+ (lambda (source1 source2 target)
+ ((fixnum-2-args/operator operation) target source1 source2 overflow?))))
+
+(define (fixnum-2-args/operator operation)
+ (lookup-arithmetic-method operation fixnum-methods/2-args))
+
+(define fixnum-methods/2-args
+ (list 'FIXNUM-METHODS/2-ARGS))
+
+(define (do-overflow-addition tgt src1 src2)
+ (let ((label-1 (generate-label))
+ (label-2 (generate-label)))
+ (LAP (ADDI ,regnum:assembler-temp 0 0)
+ (XOR ,regnum:first-arg ,src1 ,src2)
+ (BLTZ ,regnum:first-arg (@PCR ,label-1))
+ (ADDU ,regnum:first-arg ,src1 ,src2)
+ (XOR ,regnum:first-arg ,src1 ,regnum:first-arg)
+ (BGEZ ,regnum:first-arg (@PCR ,label-2))
+ (ADDU ,tgt ,src1 ,src2)
+ (ADDI ,regnum:assembler-temp 0 1)
+ (LABEL ,label-1)
+ (ADDU ,tgt ,src1 ,src2)
+ (LABEL ,label-2))))
+
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (do-overflow-addition tgt src1 src2)
+ (LAP (ADDU ,tgt ,src1 ,src2)))))
+
+(define (do-overflow-subtraction tgt src1 src2)
+ (let ((label-1 (generate-label))
+ (label-2 (generate-label)))
+ (LAP (ADDI ,regnum:assembler-temp 0 0)
+ (XOR ,regnum:first-arg ,src1 ,src2)
+ (BGEZ ,regnum:first-arg (@PCR ,label-1))
+ (SUBU ,regnum:first-arg ,src1 ,src2)
+ (XOR ,regnum:first-arg ,regnum:first-arg ,src1)
+ (BGEZ ,regnum:first-arg (@PCR ,label-2))
+ (SUBU ,tgt ,src1 ,src2)
+ (ADDI ,regnum:assembler-temp 0 1)
+ (LABEL ,label-1)
+ (SUBU ,tgt ,src1 ,src2)
+ (LABEL ,label-2))))
+
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (do-overflow-subtraction tgt src1 src2)
+ (LAP (SUB ,tgt ,src1 ,src2)))))
+
+(define (do-multiply tgt src1 src2 overflow?)
+ (if overflow?
+ (let ((temp (standard-temporary!))
+ (label-1 (generate-label)))
+ (LAP (SRL ,regnum:first-arg ,src1 6) ; Unshift 1st arg.
+ (MULT ,regnum:first-arg ,src2) ; Result is left justified
+ (MFLO ,temp)
+ (SRA ,temp ,temp 31) ; Get sign bit only
+ (MFHI ,regnum:first-arg) ; Should match the sign
+ (BNE ,regnum:first-arg ,temp (@pcr ,label-1))
+ (ADDI ,regnum:assembler-temp 0 1) ; Set overflow flag
+ (ADDI ,regnum:assembler-temp 0 0) ; Clear overflow flag
+ (MFLO ,tgt)
+ (LABEL ,label-1)))
+ (LAP (SRL ,regnum:assembler-temp ,src1 6)
+ (MULT ,regnum:assembler-temp ,src2)
+ (MFLO ,tgt))))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args do-multiply)
+\f
+(define-rule statement
+ ;; execute binary fixnum operation with constant second arg
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (? overflow?)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ ((fixnum-2-args/operator/register*constant operation)
+ target source constant overflow?))))
+
+(define-rule statement
+ ;; execute binary fixnum operation with constant first arg
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (REGISTER (? source))
+ (? overflow?)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (if (fixnum-2-args/commutative? operation)
+ ((fixnum-2-args/operator/register*constant operation)
+ target source constant overflow?)
+ ((fixnum-2-args/operator/constant*register operation)
+ target constant source overflow?)))))
+\f
+(define (fixnum-2-args/commutative? operator)
+ (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
+
+(define (fixnum-2-args/operator/register*constant operation)
+ (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
+
+(define fixnum-methods/2-args/register*constant
+ (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
+
+(define-arithmetic-method 'PLUS-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (if overflow?
+ (if (zero? constant)
+ (LAP (ADDI ,regnum:assembler-temp 0 0))
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-fixnum-constant constant temp)
+ ,@(do-overflow-addition tgt src temp))))
+ (add-immediate (* fixnum-1 constant) src tgt))))
+
+(define-arithmetic-method 'MINUS-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (if overflow?
+ (if (zero? constant)
+ (LAP (ADDI ,regnum:assembler-temp 0 0)
+ (ADD ,tgt 0 ,src))
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-fixnum-constant constant temp)
+ ,@(do-overflow-subtraction tgt src temp))))
+ (add-immediate (- (* constant fixnum-1)) src tgt))))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (define (power-of-two? integer)
+ (cond ((<= integer 0) #F)
+ ((= integer 1) 0)
+ ((odd? integer) #F)
+ ((power-of-two? (quotient integer 2)) => 1+)
+ (else #F)))
+ (define (multiply-by-power-of-two what-power)
+ (if overflow?
+ (let ((label-1 (generate-label)))
+ (LAP (SLL ,regnum:first-arg ,src ,what-power)
+ (SRA ,regnum:assembler-temp ,regnum:first-arg ,what-power)
+ (BNE ,regnum:assembler-temp ,src (@pcr ,label-1))
+ (ADDI ,regnum:assembler-temp 0 1)
+ (ADDI ,regnum:assembler-temp 0 0)
+ (SLL ,tgt ,src ,what-power)
+ (LABEL ,label-1)))
+ (LAP (SLL ,tgt ,src ,what-power))))
+ (cond ((zero? constant)
+ (LAP ,@(if overflow?
+ (LAP (ADDI ,regnum:assembler-temp 0 0))
+ '())
+ (ADDI ,tgt 0 0)))
+ ((= constant 1)
+ (LAP ,@(if overflow?
+ (LAP (ADDI ,regnum:assembler-temp 0 0))
+ '())
+ (ADD ,tgt 0 ,src)))
+ ((power-of-two? constant) => multiply-by-power-of-two)
+ (else
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-fixnum-constant constant temp)
+ ,@(do-multiply tgt src temp overflow?)))))))
+
+(define (fixnum-2-args/operator/constant*register operation)
+ (lookup-arithmetic-method operation
+ fixnum-methods/2-args/constant*register))
+
+(define fixnum-methods/2-args/constant*register
+ (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
+
+(define-arithmetic-method 'MINUS-FIXNUM
+ fixnum-methods/2-args/constant*register
+ (lambda (tgt constant src overflow?)
+ (guarantee-signed-fixnum constant)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-fixnum-constant constant temp)
+ ,@(if overflow?
+ (do-overflow-subtraction tgt temp src)
+ (LAP (SUB ,tgt ,temp ,src)))))))
+
+(define (guarantee-signed-fixnum n)
+ (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
+ n)
+
+(define (signed-fixnum? n)
+ (and (exact-integer? n)
+ (>= n signed-fixnum/lower-limit)
+ (< n signed-fixnum/upper-limit)))
+\f
+;;;; Predicates
+
+;;; This is a kludge. It assumes that the last instruction of the
+;;; arithmetic operation that may cause an overflow condition will
+;;; have set regnum:assembler-temp to 0 if there is no overflow.
+
+(define-rule predicate
+ (OVERFLOW-TEST)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (BNE ,regnum:assembler-temp 0 (@PCR ,label)) (NOP)))
+ (lambda (label)
+ (LAP (BEQ ,regnum:assembler-temp 0 (@PCR ,label)) (NOP))))
+ (LAP))
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ (compare (fixnum-pred-1->cc predicate)
+ (standard-source! source)
+ 0))
+
+(define (fixnum-pred-1->cc predicate)
+ (case predicate
+ ((ZERO-FIXNUM?) '=)
+ ((NEGATIVE-FIXNUM?) '<)
+ ((POSITIVE-FIXNUM?) '>)
+ (else (error "unknown fixnum predicate" predicate))))
+\f
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (compare (fixnum-pred-2->cc predicate)
+ (standard-source! source1)
+ (standard-source! source2)))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (compare-fixnum/constant*register (invert-condition-noncommutative
+ (fixnum-pred-2->cc predicate))
+ constant
+ (standard-source! source)))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (REGISTER (? source)))
+ (compare-fixnum/constant*register (fixnum-pred-2->cc predicate)
+ constant
+ (standard-source! source)))
+
+(define-integrable (compare-fixnum/constant*register cc n r)
+ (guarantee-signed-fixnum n)
+ (compare-immediate cc (* n fixnum-1) r))
+
+(define (fixnum-pred-2->cc predicate)
+ (case predicate
+ ((EQUAL-FIXNUM?) '=)
+ ((LESS-THAN-FIXNUM?) '<)
+ ((GREATER-THAN-FIXNUM?) '>)
+ (else (error "unknown fixnum predicate" predicate))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulflo.scm,v 1.1 1990/05/07 04:17:41 jinx Exp $
+$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $
+
+Copyright (c) 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Flonum rules
+
+(declare (usual-integrations))
+\f
+(define (flonum-source! register)
+ (float-register->fpr (load-alias-register! register 'FLOAT)))
+
+(define (flonum-target! pseudo-register)
+ (delete-dead-registers!)
+ (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT)))
+
+(define (flonum-temporary!)
+ (float-register->fpr (allocate-temporary-register! 'FLOAT)))
+
+(define (store-flonum offset base source)
+ (fp-store-doubleword offset base
+ (fpr->float-register source)))
+
+(define (load-flonum offset base target)
+ (fp-load-doubleword offset base
+ (fpr->float-register target)
+ #t)) ; Output NOP
+
+(define-rule statement
+ ;; convert a floating-point number to a flonum object
+ (ASSIGN (REGISTER (? target))
+ (FLOAT->OBJECT (REGISTER (? source))))
+ (let ((source (flonum-source! source)))
+ (let ((target (standard-target! target)))
+ (LAP
+ ; (SW 0 (OFFSET 0 ,regnum:free)) ; make heap parsable forwards
+ (SRL ,regnum:free ,regnum:free 3)
+ (SLL ,regnum:free ,regnum:free 3)
+ (ORI ,regnum:free ,regnum:free #b100) ; Align to odd quad byte
+ (ADD ,target 0 ,regnum:free) ; Result is this address
+ ,@(deposit-type (ucode-type flonum) target)
+ ,@(load-non-pointer
+ (ucode-type manifest-nm-vector) 2 regnum:assembler-temp)
+ (SW ,regnum:assembler-temp (OFFSET 0 ,regnum:free))
+ ,@(store-flonum 4 regnum:free source)
+ (ADDI ,regnum:free ,regnum:free 12)))))
+
+(define-rule statement
+ ;; convert a flonum object address to a floating-point number
+ (ASSIGN (REGISTER (? target)) (@ADDRESS->FLOAT (REGISTER (? source))))
+ (let ((source (standard-source! source)))
+ (let ((target (flonum-target! target)))
+ (load-flonum 4 source target))))
+\f
+;;;; Flonum Arithmetic
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
+ overflow? ;ignore
+ (let ((source (flonum-source! source)))
+ ((flonum-1-arg/operator operation) (flonum-target! target) source)))
+
+(define (flonum-1-arg/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/1-arg))
+
+(define flonum-methods/1-arg
+ (list 'FLONUM-METHODS/1-ARG))
+
+;;; Notice the weird ,', syntax here.
+;;; If LAP changes, this may also have to change.
+
+(let-syntax
+ ((define-flonum-operation
+ (macro (primitive-name opcode)
+ `(define-arithmetic-method ',primitive-name flonum-methods/1-arg
+ (lambda (target source)
+ (LAP (,opcode DOUBLE ,',target ,',source)))))))
+ (define-flonum-operation flonum-abs FABS)
+ (define-flonum-operation flonum-negate FNEG))
+
+; Well, I thought this would work, but the fine print in the manual
+; says that CVT.D only works with a source type of single precision.
+; *Sigh*
+
+; (define-arithmetic-method 'FLONUM-ROUND flonum-methods/1-arg
+; (lambda (target source)
+; (let ((temp (standard-temporary!)))
+; (LAP (CFC1 ,regnum:assembler-temp 31) ; Status register
+; (ORI ,temp ,regnum:assembler-temp 3) ; Rounding Mode <-
+; (XORI ,temp ,temp 3) ;; 0 (nearest)
+; (CTC1 ,temp 31) ; Store mode back
+; (CVT.D DOUBLE ,target ,source) ; Move & round
+; (CTC1 ,regnum:assembler-temp 31))))) ; Restore status
+
+; (define-arithmetic-method 'FLONUM-TRUNCATE flonum-methods/1-arg
+; (lambda (target source)
+; (let ((temp (standard-temporary!)))
+; (LAP (CFC1 ,regnum:assembler-temp 31) ; Status register
+; (ORI ,temp ,regnum:assembler-temp 3) ; Rounding Mode <-
+; (XORI ,temp ,temp 2) ;; 1 (toward zero)
+; (CTC1 ,temp 31) ; Store mode back
+; (CVT.D DOUBLE ,target ,source) ; Move & round
+; (CTC1 ,regnum:assembler-temp 31))))) ; Restore status
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ overflow? ;ignore
+ (let ((source1 (flonum-source! source1))
+ (source2 (flonum-source! source2)))
+ ((flonum-2-args/operator operation) (flonum-target! target)
+ source1
+ source2)))
+
+(define (flonum-2-args/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/2-args))
+
+(define flonum-methods/2-args
+ (list 'FLONUM-METHODS/2-ARGS))
+
+(let-syntax
+ ((define-flonum-operation
+ (macro (primitive-name opcode)
+ `(define-arithmetic-method ',primitive-name flonum-methods/2-args
+ (lambda (target source1 source2)
+ (LAP (,opcode DOUBLE ,',target ,',source1 ,',source2)))))))
+ (define-flonum-operation flonum-add FADD)
+ (define-flonum-operation flonum-subtract FSUB)
+ (define-flonum-operation flonum-multiply FMUL)
+ (define-flonum-operation flonum-divide FDIV)
+; (define-flonum-operation flonum-remainder frem)
+ )
+\f
+;;;; Flonum Predicates
+
+(define-rule predicate
+ (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ ;; No immediate zeros, easy to generate by subtracting from itself
+ (let ((temp (flonum-temporary!))
+ (source (flonum-source! source)))
+ (LAP (FSUB DOUBLE ,temp ,source ,source)
+ ,@(flonum-compare
+ (case predicate
+ ((FLONUM-ZERO?) 'C.EQ)
+ ((FLONUM-NEGATIVE?) 'C.LT)
+ ((FLONUM-POSITIVE?) 'C.GT)
+ (else (error "unknown flonum predicate" predicate)))
+ source temp))))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (flonum-compare (case predicate
+ ((FLONUM-EQUAL?) 'C.EQ)
+ ((FLONUM-LESS?) 'C.LT)
+ ((FLONUM-GREATER?) 'C.GT)
+ (else (error "unknown flonum predicate" predicate)))
+ (flonum-source! source1)
+ (flonum-source! source2)))
+
+(define (flonum-compare cc r1 r2)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (BC1T (@PCR ,label)) (NOP)))
+ (lambda (label)
+ (LAP (BC1F (@PCR ,label)) (NOP))))
+ (if (eq? cc 'C.GT)
+ (LAP (C.LT DOUBLE ,r2 ,r1))
+ (LAP (,cc DOUBLE ,r1 ,r2))))
+
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulrew.scm,v 1.1 1990/05/07 04:18:00 jinx Rel $
+$MC68020-Header: rulrew.scm,v 1.1 90/01/18 22:48:52 GMT cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rewrite Rules
+
+(declare (usual-integrations))
+\f
+;;;; Synthesized Data
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (REGISTER (? datum register-known-value)))
+ (QUALIFIER (and (rtl:machine-constant? type)
+ (rtl:machine-constant? datum)))
+ (rtl:make-cons-pointer type datum))
+
+;; I've copied these rules from the MC68020. -- Jinx.
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
+ (QUALIFIER
+ (and (rtl:object->type? type)
+ (rtl:constant? (rtl:object->type-expression type))))
+ (rtl:make-cons-pointer
+ (rtl:make-machine-constant
+ (object-type (rtl:object->type-expression datum)))
+ datum))
+
+(define-rule rewriting
+ (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
+ (QUALIFIER
+ (and (rtl:object->datum? datum)
+ (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
+ (rtl:make-cons-pointer
+ type
+ (rtl:make-machine-constant
+ (careful-object-datum (rtl:object->datum-expression datum)))))
+
+(define-rule rewriting
+ (OBJECT->TYPE (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant? source))
+ (rtl:make-machine-constant (object-type (rtl:constant-value source))))
+
+(define-rule rewriting
+ (OBJECT->DATUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-non-pointer? source))
+ (rtl:make-machine-constant (careful-object-datum source)))
+
+(define (rtl:constant-non-pointer? expression)
+ (and (rtl:constant? expression)
+ (non-pointer-object? (rtl:constant-value expression))))
+\f
+;; I've modified these rules from the MC68020. -- Jinx
+
+;;; These rules are losers because there's no abstract way to cons a
+;;; statement or a predicate without also getting some CFG structure.
+
+(define-rule rewriting
+ ;; Use register 0, always 0.
+ (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'ASSIGN target (rtl:make-machine-constant 0)))
+
+(define-rule rewriting
+ ;; Compare to register 0, always 0.
+ (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-constant 0)))
+
+(define-rule rewriting
+ ;; Compare to register 0, always 0.
+ (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-constant 0)))
+
+(define (rtl:immediate-zero-constant? expression)
+ (cond ((rtl:constant? expression)
+ (let ((value (rtl:constant-value expression)))
+ (and (non-pointer-object? value)
+ (zero? (object-type value))
+ (zero? (careful-object-datum value)))))
+ ((rtl:cons-pointer? expression)
+ (and (let ((expression (rtl:cons-pointer-type expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))
+ (let ((expression (rtl:cons-pointer-datum expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))))
+ (else false)))
+\f
+;;;; Fixnums
+
+;; I've copied this rule from the MC68020. -- Jinx
+;; It should probably be qualified to be in the immediate range.
+
+(define-rule rewriting
+ (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-fixnum? source))
+ (rtl:make-object->fixnum source))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (REGISTER (? operand-1 register-known-value))
+ (? operand-2)
+ #F)
+ (QUALIFIER (rtl:constant-fixnum-4? operand-1))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ #F)
+ (QUALIFIER (rtl:constant-fixnum-4? operand-2))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (REGISTER (? operand-1 register-known-value))
+ (? operand-2)
+ #F)
+ (QUALIFIER
+ (and (rtl:object->fixnum-of-register? operand-1)
+ (rtl:constant-fixnum-4? operand-2)))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ #F)
+ (QUALIFIER
+ (and (rtl:constant-fixnum-4? operand-1)
+ (rtl:object->fixnum-of-register? operand-2)))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
+
+(define (rtl:constant-fixnum? expression)
+ (and (rtl:constant? expression)
+ (fix:fixnum? (rtl:constant-value expression))))
+
+(define (rtl:constant-fixnum-4? expression)
+ (and (rtl:object->fixnum? expression)
+ (let ((expression (rtl:object->fixnum-expression expression)))
+ (and (rtl:constant? expression)
+ (eqv? 4 (rtl:constant-value expression))))))
+
+(define (rtl:object->fixnum-of-register? expression)
+ (and (rtl:object->fixnum? expression)
+ (rtl:register? (rtl:object->fixnum-expression expression))))
+\f
+;;;; Closures and othe optimizations.
+
+;; These rules are Spectrum specific
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (REGISTER (? datum register-known-value)))
+ (QUALIFIER (and (rtl:machine-constant? type)
+ (= (rtl:machine-constant-value type)
+ (ucode-type compiled-entry))
+ (or (rtl:entry:continuation? datum)
+ (rtl:entry:procedure? datum)
+ (rtl:cons-closure? datum))))
+ (rtl:make-cons-pointer type datum))
+
+#|
+;; Not yet written.
+
+;; A type is compatible when a depi instruction can put it in assuming that
+;; the datum has the quad bits set.
+;; A register is a machine-address-register if it is a machine register and
+;; always contains an address (ie. free pointer, stack pointer, or dlink register)
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (REGISTER (? datum machine-address-register)))
+ (QUALIFIER (and (rtl:machine-constant? type)
+ (spectrum-type-optimizable? (rtl:machine-constant-value type))))
+ (rtl:make-cons-pointer type datum))
+|#
+
+
+
\ No newline at end of file
projects / mit-scheme.git / commitdiff