--- /dev/null
+#| -*-Scheme-*-
+
+$Id: assmd.scm,v 1.1 1992/08/29 13:51:15 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; Assembler Machine Dependencies
+;;; Package: (compiler assembler)
+
+(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
+ 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 halfword (32 bits) boundary.
+ (- (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 (instruction-initial-position block) 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 (instruction-append x y)
+ (bit-string-append x y))
+
+;;; end let-syntax
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: coerce.scm,v 1.1 1992/08/29 13:51:16 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+(declare (usual-integrations))
+\f
+;;;; Alpha coercions
+;;; Package: (compiler lap-syntaxer)
+
+;;; 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-2-bit-unsigned (make-coercion 'UNSIGNED 2))
+(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
+(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
+(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
+(define coerce-7-bit-unsigned (make-coercion 'UNSIGNED 7))
+(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
+(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11))
+(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
+(define coerce-26-bit-unsigned (make-coercion 'UNSIGNED 26))
+
+(define coerce-14-bit-signed (make-coercion 'SIGNED 14))
+(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
+(define coerce-21-bit-signed (make-coercion 'SIGNED 21))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compiler.cbf,v 1.1 1992/08/29 13:51:17 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; Script to incrementally compile the compiler (from .bins)
+
+(for-each compile-directory
+ '("back"
+ "base"
+ "fggen"
+ "fgopt"
+ "machines/alpha"
+ "rtlbase"
+ "rtlgen"
+ "rtlopt"))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compiler.pkg,v 1.1 1992/08/29 13:51:17 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. 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/alpha/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:intersperse-rtl-in-lap?
+ 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?
+ compiler:use-multiclosures?))
+\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/alpha/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
+ compile-scode
+ 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
+ inf-structure->bif/bsm)
+ (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!)
+ (export (compiler)
+ indirection-block-procedure))
+
+(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/alpha/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-cons-closure-indirection
+ make-cons-closure-redirection
+ make-closure-redirection
+ make-ic-cons
+ make-non-trivial-closure-cons
+ make-trivial-closure-cons
+ redirect-closure))
+
+(define-package (compiler rtl-generator generate/combination)
+ (files "rtlgen/rgcomb")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator)
+ generate/combination)
+ (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/alpha/lapgen" ;code generation rules
+ "machines/alpha/rules1" ; " " "
+ "machines/alpha/rules2" ; " " "
+ "machines/alpha/rules3" ; " " "
+ "machines/alpha/rules4" ; " " "
+ "machines/alpha/rulfix" ; " " "
+ "machines/alpha/rulflo" ; " " "
+ "machines/alpha/rulrew" ;code rewriting rules
+ "back/syntax" ;Generic syntax phase
+ "back/syerly" ;Early binding version
+ "machines/alpha/coerce" ;Coercions: integer -> bit string
+ "back/asmmac" ;Macros for hairy syntax
+ "machines/alpha/insmac" ;Macros for hairy syntax
+ "machines/alpha/inerly" ;Early binding version
+ "machines/alpha/instr1" ;Alpha instruction set
+ "machines/alpha/instr2" ;branch tensioning: branches
+ "machines/alpha/instr3" ;floating point
+ )
+ (parent (compiler))
+ (export (compiler)
+ fits-in-16-bits-signed?
+ fits-in-16-bits-unsigned?
+ top-16-of-32-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-global-links*
+ *interned-static-variables*
+ *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
+ add-end-of-block-code!)
+ (export (compiler top-level)
+ linearize-lap
+ initialize-lap-linearizer!))
+\f
+(define-package (compiler lap-optimizer)
+ (files "machines/alpha/lapopt")
+ (parent (compiler))
+ (export (compiler top-level)
+ optimize-linear-lap))
+
+(define-package (compiler assembler)
+ (files "machines/alpha/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/alpha/dassm1"
+ "machines/alpha/dassm2"
+ "machines/alpha/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-*-
+
+$Id: dassm1.scm,v 1.1 1992/08/29 13:51:18 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+;;;; Disassembler: User Level
+;;; Package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+;;; Flags that control disassembler behavior
+
+(define disassembler/symbolize-output? true)
+(define disassembler/compiled-code-heuristics?
+ ;; Not used for anything! (Reserved for future use?)
+ 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-*-
+
+$Id: dassm2.scm,v 1.1 1992/08/29 13:51:19 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; Alpha Disassembler: Top Level
+;;; Package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+(set! compiled-code-block/bytes-per-object 4)
+(set! compiled-code-block/objects-per-procedure-cache 2)
+(set! compiled-code-block/objects-per-variable-cache 1)
+
+(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)
+ (if (not (eq? state 'INSTRUCTION))
+ (error "Unexpected disassembler state" state))
+ (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
+ instruction
+ next-state))))))))
+\f
+(define (disassembler/initial-state)
+ 'INSTRUCTION-NEXT)
+
+(define (disassembler/next-state instruction state)
+ instruction state
+ '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)
+ (let ((do-it
+ (lambda (format-word offset)
+ `(EXTERNAL-LABEL (FORMAT ,format-word)
+ ,(offset->@pcr (* 2 offset))))))
+ (if (eq? endianness 'LITTLE)
+ (do-it (extract bit-string 0 16)
+ (extract bit-string 16 32))
+ (do-it (extract bit-string 16 32)
+ (extract bit-string 0 16)))))
+
+(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)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: dassm3.scm,v 1.1 1992/08/29 13:51:20 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;; Alpha Disassembler: Internals
+;;; Package: (compiler disassembler)
+
+(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)))
+\f
+;;;; instr1.scm
+
+(define (disassemble-memory-format op-name word)
+ `(,op-name ,(extract word 21 26)
+ (OFFSET ,(extract-signed word 0 16) ,(extract word 16 21))))
+
+(vector-set! disassemblers #x08
+ (lambda (word)
+ (let ((base (extract word 16 21)))
+ (if (zero? base)
+ `(MOVEI ,(extract word 21 26)
+ (& ,(extract-signed word 0 16)))
+ `(LDA ,(extract word 21 26)
+ (OFFSET ,(extract-signed word 0 16)
+ ,(extract word 16 21)))))))
+(vector-set! disassemblers #x09
+ (lambda (word) (disassemble-memory-format 'LDAH word)))
+(vector-set! disassemblers #x20
+ (lambda (word) (disassemble-memory-format 'LDF word)))
+(vector-set! disassemblers #x21
+ (lambda (word) (disassemble-memory-format 'LDG word)))
+(vector-set! disassemblers #x28
+ (lambda (word) (disassemble-memory-format 'LDL word)))
+(vector-set! disassemblers #x2A
+ (lambda (word) (disassemble-memory-format 'LDL_L word)))
+(vector-set! disassemblers #x29
+ (lambda (word) (disassemble-memory-format 'LDQ word)))
+(vector-set! disassemblers #x2B
+ (lambda (word) (disassemble-memory-format 'LDQ_L word)))
+(vector-set! disassemblers #x0B
+ (lambda (word) (disassemble-memory-format 'LDQ_U word)))
+(vector-set! disassemblers #x22
+ (lambda (word) (disassemble-memory-format 'LDS word)))
+(vector-set! disassemblers #x23
+ (lambda (word) (disassemble-memory-format 'LDT word)))
+(vector-set! disassemblers #x24
+ (lambda (word) (disassemble-memory-format 'STF word)))
+(vector-set! disassemblers #x25
+ (lambda (word) (disassemble-memory-format 'STG word)))
+(vector-set! disassemblers #x2C
+ (lambda (word) (disassemble-memory-format 'STL word)))
+(vector-set! disassemblers #x2E
+ (lambda (word) (disassemble-memory-format 'STL_C word)))
+(vector-set! disassemblers #x2D
+ (lambda (word) (disassemble-memory-format 'STQ word)))
+(vector-set! disassemblers #x2F
+ (lambda (word) (disassemble-memory-format 'STQ_C word)))
+(vector-set! disassemblers #x0F
+ (lambda (word) (disassemble-memory-format 'STQ_U word)))
+(vector-set! disassemblers #x26
+ (lambda (word) (disassemble-memory-format 'STS word)))
+(vector-set! disassemblers #x27
+ (lambda (word) (disassemble-memory-format 'STT word)))
+
+(define operate-10-disassemblers (make-vector #x6D handle-bad-instruction))
+(vector-set! disassemblers #x10
+ (lambda (word)
+ ((vector-ref operate-10-disassemblers (extract word 12 5))
+ word)))
+(define operate-11-disassemblers (make-vector #x66 handle-bad-instruction))
+(vector-set! disassemblers #x11
+ (lambda (word)
+ ((vector-ref operate-11-disassemblers (extract word 12 5))
+ word)))
+(define operate-12-disassemblers (make-vector #x7A handle-bad-instruction))
+(vector-set! disassemblers #x12
+ (lambda (word)
+ ((vector-ref operate-12-disassemblers (extract word 12 5))
+ word)))
+(define operate-13-disassemblers (make-vector #x60 handle-bad-instruction))
+(vector-set! disassemblers #x13
+ (lambda (word)
+ ((vector-ref operate-13-disassemblers (extract word 5 12))
+ word)))
+
+(vector-set! operate-11-disassemblers #x20
+ (lambda (word)
+ (let ((Ra (extract word 21 26))
+ (Rc (extract word 0 5)))
+ (if (bit-string-ref word 12)
+ (invalid-instruction)
+ (let ((sbz (extract word 13 16))
+ (Rb (extract word 16 21)))
+ (if (not (zero? sbz))
+ (invalid-instruction))
+ (if (not (= Ra Rb))
+ (invalid-instruction))
+ `(COPY ,Ra ,Rc))))))
+
+(vector-set! disassemblers #x18
+ (lambda (word)
+ (case (extract word 0 16)
+ ((#x0000) '(TRAPB))
+ ((#x4000) '(MB))
+ ((#x8000) `(FETCH ,(extract word 16 21)))
+ ((#xA000) `(FETCH_M ,(extract word 16 21)))
+ ((#xC000) `(RPCC ,(extract word 21 26)))
+ ((#xE000) `(RC ,(extract word 21 26)))
+ ((#xF000) `(RS ,(extract word 21 26))))))
+
+(define ((disassemble-operate-format op-name) word)
+ (let ((Ra (extract word 21 26))
+ (Rc (extract word 0 5)))
+ (if (bit-string-ref word 12)
+ (let ((lit (extract word 13 21)))
+ `(,op-name ,Ra (& ,lit) ,Rc))
+ (let ((sbz (extract word 13 16))
+ (Rb (extract word 16 21)))
+ (if (not (zero? sbz))
+ (invalid-instruction))
+ `(,op-name ,Ra ,Rb ,Rc)))))
+
+(vector-set! operate-10-disassemblers #x00
+ (disassemble-operate-format 'ADDL))
+(vector-set! operate-10-disassemblers #x40
+ (disassemble-operate-format 'ADDLV))
+(vector-set! operate-10-disassemblers #x20
+ (disassemble-operate-format 'ADDQ))
+(vector-set! operate-10-disassemblers #x60
+ (disassemble-operate-format 'ADDQV))
+(vector-set! operate-11-disassemblers #x00
+ (disassemble-operate-format 'AND))
+(vector-set! operate-11-disassemblers #x08
+ (disassemble-operate-format 'BIC))
+(vector-set! operate-11-disassemblers #x20
+ (disassemble-operate-format 'BIS))
+(vector-set! operate-11-disassemblers #x24
+ (disassemble-operate-format 'CMOVEQ))
+(vector-set! operate-11-disassemblers #x46
+ (disassemble-operate-format 'CMOVGE))
+(vector-set! operate-11-disassemblers #x66
+ (disassemble-operate-format 'CMOVGT))
+(vector-set! operate-11-disassemblers #x16
+ (disassemble-operate-format 'CMOVLBC))
+(vector-set! operate-11-disassemblers #x14
+ (disassemble-operate-format 'CMOVLBS))
+(vector-set! operate-11-disassemblers #x64
+ (disassemble-operate-format 'CMOVLE))
+(vector-set! operate-11-disassemblers #x44
+ (disassemble-operate-format 'CMOVLT))
+(vector-set! operate-11-disassemblers #x26
+ (disassemble-operate-format 'CMOVNE))
+(vector-set! operate-10-disassemblers #x2D
+ (disassemble-operate-format 'CMPEQ))
+(vector-set! operate-10-disassemblers #x6D
+ (disassemble-operate-format 'CMPLE))
+(vector-set! operate-10-disassemblers #x4D
+ (disassemble-operate-format 'CMPLT))
+(vector-set! operate-10-disassemblers #x3D
+ (disassemble-operate-format 'CMPULE))
+(vector-set! operate-10-disassemblers #x1D
+ (disassemble-operate-format 'CMPULT))
+(vector-set! operate-11-disassemblers #x48
+ (disassemble-operate-format 'EQV))
+(vector-set! operate-12-disassemblers #x06
+ (disassemble-operate-format 'EXTBL))
+(vector-set! operate-12-disassemblers #x6A
+ (disassemble-operate-format 'EXTLH))
+(vector-set! operate-12-disassemblers #x26
+ (disassemble-operate-format 'EXTLL))
+(vector-set! operate-12-disassemblers #x7A
+ (disassemble-operate-format 'EXTQH))
+(vector-set! operate-12-disassemblers #x36
+ (disassemble-operate-format 'EXTQL))
+(vector-set! operate-12-disassemblers #x5A
+ (disassemble-operate-format 'EXTWH))
+(vector-set! operate-12-disassemblers #x16
+ (disassemble-operate-format 'EXTWL))
+(vector-set! operate-12-disassemblers #x0B
+ (disassemble-operate-format 'INSBL))
+(vector-set! operate-12-disassemblers #x67
+ (disassemble-operate-format 'INSLH))
+(vector-set! operate-12-disassemblers #x2B
+ (disassemble-operate-format 'INSLL))
+(vector-set! operate-12-disassemblers #x77
+ (disassemble-operate-format 'INSQH))
+(vector-set! operate-12-disassemblers #x3B
+ (disassemble-operate-format 'INSQL))
+(vector-set! operate-12-disassemblers #x57
+ (disassemble-operate-format 'INSWH))
+(vector-set! operate-12-disassemblers #x1B
+ (disassemble-operate-format 'INSWL))
+(vector-set! operate-12-disassemblers #x02
+ (disassemble-operate-format 'MSKBL))
+(vector-set! operate-12-disassemblers #x62
+ (disassemble-operate-format 'MSKLH))
+(vector-set! operate-12-disassemblers #x22
+ (disassemble-operate-format 'MSKLL))
+(vector-set! operate-12-disassemblers #x72
+ (disassemble-operate-format 'MSKQH))
+(vector-set! operate-12-disassemblers #x32
+ (disassemble-operate-format 'MSKQL))
+(vector-set! operate-12-disassemblers #x52
+ (disassemble-operate-format 'MSKWH))
+(vector-set! operate-12-disassemblers #x12
+ (disassemble-operate-format 'MSKWL))
+(vector-set! operate-13-disassemblers #x00
+ (disassemble-operate-format 'MULL))
+(vector-set! operate-13-disassemblers #x40
+ (disassemble-operate-format 'MULLV))
+(vector-set! operate-13-disassemblers #x20
+ (disassemble-operate-format 'MULQ))
+(vector-set! operate-13-disassemblers #x60
+ (disassemble-operate-format 'MULQV))
+(vector-set! operate-11-disassemblers #x28
+ (disassemble-operate-format 'ORNOT))
+(vector-set! operate-10-disassemblers #x02
+ (disassemble-operate-format 'S4ADDL))
+(vector-set! operate-10-disassemblers #x22
+ (disassemble-operate-format 'S4ADDQ))
+(vector-set! operate-10-disassemblers #x0B
+ (disassemble-operate-format 'S4SUBL))
+(vector-set! operate-10-disassemblers #x2B
+ (disassemble-operate-format 'S4SUBQ))
+(vector-set! operate-10-disassemblers #x12
+ (disassemble-operate-format 'S8ADDL))
+(vector-set! operate-10-disassemblers #x32
+ (disassemble-operate-format 'S8ADDQ))
+(vector-set! operate-10-disassemblers #x1B
+ (disassemble-operate-format 'S8SUBL))
+(vector-set! operate-10-disassemblers #x3B
+ (disassemble-operate-format 'S8SUBQ))
+(vector-set! operate-12-disassemblers #x39
+ (disassemble-operate-format 'SLL))
+(vector-set! operate-12-disassemblers #x3C
+ (disassemble-operate-foramt 'SRA))
+(vector-set! operate-12-disassemblers #x34
+ (disassemble-operate-foramt 'SRL))
+(vector-set! operate-10-disassemblers #x09
+ (disassemble-operate-format 'SUBL))
+(vector-set! operate-10-disassemblers #x49
+ (disassemble-operate-format 'SUBLV))
+(vector-set! operate-10-disassemblers #x29
+ (disassemble-operate-format 'SUBQ))
+(vector-set! operate-10-disassemblers #x69
+ (disassemble-operate-format 'SUBQV))
+(vector-set! operate-13-disassemblers #x30
+ (disassemble-operate-format 'UMULH))
+(vector-set! operate-11-disassemblers #x40
+ (disassemble-operate-format 'XOR))
+(vector-set! operate-12-disassemblers #x30
+ (disassemble-operate-format 'ZAP))
+(vector-set! operate-12-disassemblers #x31
+ (disassemble-operate-format 'ZAPNOT))
+
+;;; Punt PAL code for now!!!
+(define pal-op-codes (make-vector #x1E handle-bad-instruction))
+
+(vector-set! disassemblers #x00
+ (lambda (word)
+ (let ((function-code (extract word 0 26)))
+ (cond ((zero? function-code)
+ '(HALT))
+ ((and (<= function-code #x9D)
+ (<= #x80 function-code))
+ (vector-ref pal-op-codes (- function-code #x80)))
+ (else (invalid-instruction))))))
+
+(vector-set! pal-op-codes #x00 '(BPT))
+(vector-set! pal-op-codes #x01 '(BUGCHK))
+(vector-set! pal-op-codes #x02 '(CHME))
+(vector-set! pal-op-codes #x03 '(CHMK))
+(vector-set! pal-op-codes #x04 '(CHMS))
+(vector-set! pal-op-codes #x05 '(CHMU))
+(vector-set! pal-op-codes #x06 '(IMB))
+(vector-set! pal-op-codes #x07 '(INSQHIL))
+(vector-set! pal-op-codes #x08 '(INSQTIL))
+(vector-set! pal-op-codes #x09 '(INSQHIQ))
+(vector-set! pal-op-codes #x0A '(INSQTIQ))
+(vector-set! pal-op-codes #x0B '(INSQUEL))
+(vector-set! pal-op-codes #x0C '(INSQUEQ))
+(vector-set! pal-op-codes #x0D '(INSQUELD))
+(vector-set! pal-op-codes #x0E '(INSQUEQD))
+(vector-set! pal-op-codes #x0F '(PROBER))
+(vector-set! pal-op-codes #x10 '(PROBEW))
+(vector-set! pal-op-codes #x11 '(RD_PS))
+(vector-set! pal-op-codes #x12 '(REI))
+(vector-set! pal-op-codes #x13 '(REMQHIL))
+(vector-set! pal-op-codes #x14 '(REMQTIL))
+(vector-set! pal-op-codes #x15 '(REMQHIQ))
+(vector-set! pal-op-codes #x16 '(REMQTIQ))
+(vector-set! pal-op-codes #x17 '(REMQUEL))
+(vector-set! pal-op-codes #x18 '(REMQUEQ))
+(vector-set! pal-op-codes #x19 '(REMQUELD))
+(vector-set! pal-op-codes #x1A '(REMQUEQD))
+(vector-set! pal-op-codes #x1B '(SWASTEN))
+(vector-set! pal-op-codes #x1C '(WR_PS_SW))
+(vector-set! pal-op-codes #x1D '(RSCC))
+\f
+;;;; instr2.scm
+
+(vector-set! disassemblers #x1A
+ (lambda (word)
+ (let ((Ra (extract word 26 21))
+ (Rb (extract word 21 16))
+ (disp (extract-signed word 14 0))
+ (op-name (vector-ref #(JMP JSR RET COROUTINE)
+ (extract word 16 14))))
+ (if (zero? disp)
+ (if (= Ra regnum:came-from)
+ `(,op-name ,Rb)
+ `(,op-name ,Ra ,Rb))
+ `(,op-name ,Ra ,Rb ,(relative-offset
+ (extract-signed word 0 14)))))))
+
+(define ((disassemble-branch op-name) word)
+ `(,op-name ,(extract word 21 26) ,(relative-offset
+ (extract-signed word 0 21))))
+
+(define (relative-offset offset)
+ (offset->@pcr (+ *current-offset (* 4 offset))))
+
+(define (offset->@pcr offset)
+ `(@PCR ,(or (and disassembler/symbolize-output?
+ (disassembler/lookup-symbol *symbol-table offset))
+ offset)))
+
+(vector-set! disassemblers #x39 (disassemble-branch 'BEQ))
+(vector-set! disassemblers #x3E (disassemble-branch 'BGE))
+(vector-set! disassemblers #x3F (disassemble-branch 'BGT))
+(vector-set! disassemblers #x38 (disassemble-branch 'BLBC))
+(vector-set! disassemblers #x3C (disassemble-branch 'BLBS))
+(vector-set! disassemblers #x3B (disassemble-branch 'BLE))
+(vector-set! disassemblers #x3A (disassemble-branch 'BLT))
+(vector-set! disassemblers #x3D (disassemble-branch 'BNE))
+(vector-set! disassemblers #x31 (disassemble-branch 'FBEQ))
+(vector-set! disassemblers #x36 (disassemble-branch 'FBGE))
+(vector-set! disassemblers #x37 (disassemble-branch 'FBGT))
+(vector-set! disassemblers #x33 (disassemble-branch 'FBLE))
+(vector-set! disassemblers #x32 (disassemble-branch 'FBLT))
+(vector-set! disassemblers #x35 (disassemble-branch 'FBNE))
+
+(vector-set! disassemblers #x30 (disassemble-branch 'BR))
+(vector-set! disassemblers #x34 (disassemble-branch 'BSR))
+\f
+;;;; instr3.scm
+
+(define ((disassemble-float op-name) word)
+ `(,op-name ,(extract word 21 26) ,(extract word 16 21) ,(extract word 0 5)))
+
+(define float-disassemblers (make-vector #x31 handle-bad-instruction))
+
+(vector-set! disassemblers #x17
+ (lambda (word)
+ (let ((function-code (extract word 5 16)))
+ (cond ((< function-code #x31)
+ ((vector-ref float-disassemblers function-code)
+ word))
+ ((= function-code #x530)
+ ((disassemble-float 'CVTQLSV) word))
+ ((= function-code #x130)
+ ((disassemble-float 'CVTQLV) word))
+ (else (invalid-instruction))))))
+
+(vector-set! float-disassemblers #x20 (disassemble-float 'CPYS))
+(vector-set! float-disassemblers #x22 (disassemble-float 'CPYSE))
+(vector-set! float-disassemblers #x21 (disassemble-float 'CPYSN))
+(vector-set! float-disassemblers #x10 (disassemble-float 'CVTLQ))
+(vector-set! float-disassemblers #x30 (disassemble-float 'CVTQL))
+(vector-set! float-disassemblers #x2A (disassemble-float 'FCMOVEQ))
+(vector-set! float-disassemblers #x2D (disassemble-float 'FCMOVGE))
+(vector-set! float-disassemblers #x2F (disassemble-float 'FCMOVGT))
+(vector-set! float-disassemblers #x2E (disassemble-float 'FCMOVLE))
+(vector-set! float-disassemblers #x2C (disassemble-float 'FCMOVLT))
+(vector-set! float-disassemblers #x2B (disassemble-float 'FCMOVNE))
+(vector-set! float-disassemblers #x25 (disassemble-float 'MF_FPCR))
+(vector-set! float-disassemblers #x24 (disassemble-float 'MT_FPCR))
+
+(define (setup-float-disassemblers-table vector options table)
+ (let row-loop ((rows table))
+ (if (pair? rows)
+ (let ((row (car rows)))
+ (let ((op-name (car row)))
+ (let column-loop
+ ((cols (cdr row))
+ (options options))
+ (if (pair? cols)
+ (begin
+ (if (not (null? (car cols)))
+ (vector-set! vector (car cols)
+ (if (null? (car options))
+ (lambda (word)
+ `(,op-name ,(extract word 21 26)
+ ,(extract word 16 21)
+ ,(extract word 0 5)))
+ (lambda (word)
+ `(,op-name (/ . ,(car options))
+ ,(extract word 21 26)
+ ,(extract word 16 21)
+ ,(extract word 0 5))))))
+ (column-loopf (cdr cols) (cdr options))))))
+ (row-loop (cdr rows))))))
+
+(define ieee-float-disassemblers (make-vector #x7FF handle-bad-instruction))
+
+(vector-set! disassemblers #x16
+ (lambda (word)
+ (let ((function-code (extract word 5 16)))
+ ((vector-ref ieee-float-disassemblers function-code) word))))
+
+(setup-float-disassemblers-table
+ ieee-float-disassemblers
+ '( () (C) (M) (D) (U) (U C) (U M) (U D))
+ '((ADDS #x080 #x000 #x040 #x0C0 #x180 #x100 #x140 #x1C0)
+ (ADDT #x0A0 #x020 #x060 #x0E0 #x1A0 #x120 #x160 #x1E0)
+ (CMPTEQ #x0A5)
+ (CMPTLT #x0A6)
+ (CMPTLE #x0A7)
+ (CMPTUN #x0A4)
+ (CVTQS #x0BC #x03C #x07C #x0FC)
+ (CVTQT #x0BE #x03E #x07E #x0FE)
+ (CVTTS #x0AC #x02C #x06C #x0EC #x1AC #x12C #x16C #x1EC)
+ (DIVS #x083 #x003 #x043 #x0C3 #x183 #x103 #x143 #x1C3)
+ (DIVT #x0A3 #x023 #x063 #x0E3 #x1A3 #x123 #x163 #x1E3)
+ (MULS #x082 #x002 #x042 #x0C2 #x182 #x102 #x142 #x1C2)
+ (MULT #x0A2 #x022 #x062 #x0E2 #x1A2 #x122 #x162 #x1E2)
+ (SUBS #x081 #x001 #x041 #x0C1 #x181 #x101 #x141 #x1C1)
+ (SUBT #x0A1 #x021 #x061 #x0E1 #x1A1 #x121 #x161 #x1E1)))
+
+(setup-float-disassemblers-table
+ ieee-float-disassemblers
+ '( (S U)(S U C)(S U M)(S U D)(S U I)(S U I C)(S U I M)(S U I D))
+ '((ADDS #x580 #x500 #x540 #x5C0 #x780 #x700 #x740 #x7C0)
+ (ADDT #x5A0 #x520 #x560 #x5E0 #x7A0 #x720 #x760 #x7E0)
+ (CMPTEQ #x5A5)
+ (CMPTLT #x5A6)
+ (CMPTLE #x5A7)
+ (CMPTUN #x5A4)
+ (CVTQS () () () () #x7BC #x73C #x77C #x7FC)
+ (CVTQT () () () () #x7BE #x73E #x77E #x7FE)
+ (CVTTS #x5AC #x52C #x56C #x5EC #x7AC #x72C #x76C #x7EC)
+ (DIVS #x583 #x503 #x543 #x5C3 #x783 #x703 #x743 #x7C3)
+ (DIVT #x5A3 #x523 #x563 #x5E3 #x7A3 #x723 #x763 #x7E3)
+ (MULS #x582 #x502 #x542 #x5C2 #x782 #x702 #x742 #x7C2)
+ (MULT #x5A2 #x522 #x562 #x5E2 #x7A2 #x722 #x762 #x7E2)
+ (SUBS #x581 #x501 #x541 #x5C1 #x781 #x701 #x741 #x7C1)
+ (SUBT #x5A1 #x521 #x561 #x5E1 #x7A1 #x721 #x761 #x7E1)))
+
+(setup-float-disassemblers-table
+ ieee-float-disassemblers
+ '( () (C) (V) (V C) (S V) (S V C) (S V I) (S V I C))
+ '((CVTTQ #x0AF #x02F #x1AF #x12F #x5AF #x52F #x7AF #x72F)))
+
+(setup-float-disasemblers-table
+ ieee-float-disassemblers
+ '( (D) (V D) (S V D)(S V I D)(M) (V M) (S V M) (S V I M))
+ '((CVTTQ #x0EF #x1EF #x5EF #x7EF #x06F #x16F #x56F #x76F)))
+
+(define vax-float-disassemblers (make-vector #x7FF handle-bad-instruction))
+
+(vector-set! disassemblers #x15
+ (lambda (word)
+ (let ((function-code (extract word 5 16)))
+ ((vector-ref vax-float-disassemblers function-code) word))))
+
+
+(setup-float-disassemblers-table
+ vax-float-disassemblers
+ '( () (C) (U) (U C) (S) (S C) (S U) (S U C))
+ '((ADDF #x080 #x000 #x180 #x100 #x480 #x400 #x580 #x500)
+ (CVTDG #x09E #x01E #x19E #x11E #x49E #x41E #x59E #x51E)
+ (ADDG #x0A0 #x020 #x1A0 #x120 #x4A0 #x420 #x5A0 #x520)
+ (CMPGEQ #x0A5 () () () #x4A5)
+ (CMPGLT #x0A6 () () () #x4A6)
+ (CMPGLE #x0A7 () () () #x4A7)
+ (CVTGF #x0AC #x02C #x1AC #x12C #x4AC #x42C #x5AC #x52C)
+ (CVTGD #x0AD #x02D #x1AD #x12D #x4AD #x42D #x5AD #x52D)
+ (CVTQF #x0BC #x03C)
+ (CVTQG #x0BE #x03E)
+ (DIVF #x083 #x003 #x183 #x103 #x483 #x403 #x583 #x503)
+ (DIVG #x0A3 #x023 #x1A3 #x123 #x4A3 #x423 #x5A3 #x523)
+ (MULF #x082 #x002 #x182 #x102 #x482 #x402 #x582 #x502)
+ (MULG #x0A2 #x022 #x1A2 #x122 #x4A2 #x422 #x5A2 #x522)
+ (SUBF #x081 #x001 #x181 #x101 #x481 #x401 #x581 #x501)
+ (SUBG #x0A1 #x021 #x1A1 #x121 #x4A1 #x421 #x5A1 #x521)))
+
+(setup-float-disassemblers-table
+ vax-float-disassemblers
+ '( () (C) (V) (V C) (S) (S C) (S V) (S V C))
+ '((CVTGQ #x0AF #x02F #x1AF #x12F #x4AF #X42F #x5AF #x52F)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: decls.scm,v 1.1 1992/08/29 13:51:21 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; Compiler File Dependencies
+;;; package: (compiler declarations)
+
+(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
+ (append-map!
+ (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/alpha"))))
+ (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 (->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 (enough-namestring pathname))
+ (file-touch pathname))))
+
+(define (pathname-delete! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-string "\nDelete file: ")
+ (write (enough-namestring 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/alpha"
+ "dassm1" "insmac" "lapopt" "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/alpha"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
+ )
+ lap-generator-syntax-table)
+ (file-dependency/syntax/join
+ (filename/append "machines/alpha" "instr1" "instr2" "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"))
+ (alpha-base
+ (filename/append "machines/alpha" "machin"))
+ (rtl-base
+ (filename/append "rtlbase"
+ "regset" "rgraph" "rtlcfg" "rtlobj"
+ "rtlreg" "rtlty1" "rtlty2"))
+ (cse-base
+ (filename/append "rtlopt"
+ "rcse1" "rcseht" "rcserq" "rcsesr"))
+ (cse-all
+ (append (filename/append "rtlopt"
+ "rcse2" "rcseep")
+ cse-base))
+ (instruction-base
+ (filename/append "machines/alpha" "assmd" "machin"))
+ (lapgen-base
+ (append (filename/append "back" "lapgn3" "regmap")
+ (filename/append "machines/alpha" "lapgen")))
+ (assembler-base
+ (filename/append "back" "symtab"))
+ (lapgen-body
+ (append
+ (filename/append "back" "lapgn1" "lapgn2" "syntax")
+ (filename/append "machines/alpha"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo"
+ )))
+ (assembler-body
+ (append
+ (filename/append "back" "bittop")
+ (filename/append "machines/alpha"
+ "instr1" "instr2" "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/alpha" "machin" "rtlbase"
+ "rtlreg" "rtlty1" "rtlty2")
+
+ (define-integration-dependencies "rtlbase" "regset" "base")
+ (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rgraph" "machines/alpha"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlcfg" "base"
+ "cfg1" "cfg2" "cfg3")
+ (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
+ (define-integration-dependencies "rtlbase" "rtlcon" "machines/alpha"
+ "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/alpha"
+ "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/alpha"
+ "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 alpha-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 alpha-base front-end-base rtl-base))
+
+ (file-dependency/integration/join
+ (append cse-all
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
+ "rerite" "rinvex" "rlife" "rtlcsm")
+ (filename/append "machines/alpha" "rulrew"))
+ (append alpha-base rtl-base))
+
+ (file-dependency/integration/join cse-all cse-base)
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
+ (filename/append "rtlbase" "regset"))
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "rcseht" "rcserq")
+ (filename/append "base" "object"))
+
+ (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
+
+ (let ((dependents
+ (append instruction-base
+ lapgen-base
+ lapgen-body
+ assembler-base
+ assembler-body
+ (filename/append "back" "linear" "syerly"))))
+ (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
+ (file-dependency/integration/join dependents instruction-base))
+
+ (file-dependency/integration/join (append lapgen-base lapgen-body)
+ lapgen-base)
+
+ (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
+ (cons 'RELATIVE
+ (make-list
+ (length (cdr (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/alpha"
+ "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-*-
+
+$Id: inerly.scm,v 1.1 1992/08/29 13:51:22 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;; Alpha Instruction Set Macros. Early version
+;;; Package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Transformers and utilities
+
+;;; NOPs for now.
+
+(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-*-
+
+$Id: insmac.scm,v 1.1 1992/08/29 13:51:23 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; Alpha Instruction Set Macros
+;;; Package: (compiler lap-syntaxer)
+
+(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)))
+
+;;;; Fixed width instruction parsing
+
+(define (parse-instruction first-word tail early?)
+ (if (not (null? tail))
+ (error "parse-instruction: Unknown format" (cons first-word tail)))
+ (let loop ((first-word first-word))
+ (case (car first-word)
+ ((LONG)
+ (process-fields (cdr first-word) early?))
+ ((VARIABLE-WIDTH)
+ (process-variable-width first-word early?))
+ ((IF)
+ `(IF ,(cadr first-word)
+ ,(loop (caddr first-word))
+ ,(loop (cadddr first-word))))
+ (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)))))
+\f
+(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 (= 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 (zero? car-size)
+ (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-*-
+
+$Id: instr1.scm,v 1.1 1992/08/29 13:51:23 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; Alpha instruction set
+;;; Package: (compiler lap-syntaxer)
+
+;; Branch-tensioned instructions are in instr2.scm
+;; Floating point instructions are in instr3.scm
+
+(declare (usual-integrations))
+\f
+(let-syntax
+ ((memory-format-instruction
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? destination) (OFFSET (? offset) (? base)))
+ (VARIABLE-WIDTH (offset offset)
+ ((#x-8000 #x7FFF)
+ (LONG (6 ,opcode)
+ (5 destination)
+ (5 base)
+ (16 offset SIGNED)))
+ ((#x-80000000 #x7FFFFFFF)
+ ;; LDAH temp, left[offset](base)
+ ;; LDx/STx destination, right[offset](temp)
+ (LONG (6 #x09) ; LDAH
+ (5 regnum:volatile-scratch) ; destination = temp
+ (5 base) ; base
+ (16 (adjusted:high offset) SIGNED)
+ (6 ,opcode) ; LDx/STx
+ (5 destination) ; destination
+ (5 regnum:volatile-scratch) ; base = temp
+ (16 (adjusted:low offset) SIGNED)))))))))
+ (memory-format-instruction LDA #x08) ; Load Address
+ (memory-format-instruction LDAH #x09) ; Load Address High
+ (memory-format-instruction LDF #x20) ; Load F floating from memory
+ (memory-format-instruction LDG #x21) ; Load G floating from memory
+ (memory-format-instruction LDL #x28) ; Load sext long
+ (memory-format-instruction LDL_L #x2A) ; Load sext long, locked
+ (memory-format-instruction LDQ #x29) ; Load quadword
+ (memory-format-instruction LDQ_L #x2B) ; Load quadword, locked
+ (memory-format-instruction LDQ_U #x0B) ; Load quadword unaligned
+ (memory-format-instruction LDS #x22) ; Load S floating from memory
+ (memory-format-instruction LDT #x23) ; Load IEEE T floating from memory
+ (memory-format-instruction STF #x24) ; Store F floating to memory
+ (memory-format-instruction STG #x25) ; Store G floating to memory
+ (memory-format-instruction STL #x2C) ; Store long
+ (memory-format-instruction STL_C #x2E) ; Store long, conditional
+ (memory-format-instruction STQ #x2D) ; Store quadword
+ (memory-format-instruction STQ_C #x2F) ; Store quadword, conditional
+ (memory-format-instruction STQ_U #x0F) ; Store quadword unaligned
+ (memory-format-instruction STS #x26) ; Store S floating to memory
+ (memory-format-instruction STT #x27) ; Store IEEE T floating to memory
+ )
+
+(define-instruction MOVEI
+ (((? destination) (& (? constant)))
+ (LONG (6 #x08) ; LDA
+ (5 destination)
+ (5 regnum:zero)
+ (16 constant SIGNED))))
+
+(define-instruction COPY
+ (((? source) (? destination))
+ (LONG (6 #x11) ; Arithmetic/Logical
+ (5 source)
+ (5 source)
+ (3 0) ; Should be zero
+ (1 0) ; Must be zero
+ (7 #x20) ; BIS
+ (5 destination))))
+
+(let-syntax
+ ((special-memory-instruction
+ (macro (keyword functioncode)
+ `(define-instruction ,keyword
+ (()
+ (LONG (6 #x18)
+ (5 #x0)
+ (5 #x0)
+ (16 ,functioncode))))))
+ (special-memory-instruction-Ra
+ (macro (keyword functioncode)
+ `(define-instruction ,keyword
+ (((? Ra))
+ (LONG (6 #x18)
+ (5 Ra)
+ (5 #x0)
+ (16 ,functioncode))))))
+ (special-memory-instruction-Rb
+ (macro (keyword functioncode)
+ `(define-instruction ,keyword
+ (((? Rb))
+ (LONG (6 #x18)
+ (5 #x0)
+ (5 Rb)
+ (16 ,functioncode)))))))
+ (special-memory-instruction DRAINT #x0000) ; Drain instruction pipe
+ (special-memory-instruction-Rb FETCH #x8000) ; Prefetch data
+ (special-memory-instruction-Rb FETCH_M #xA000); Prefetch data, modify intent
+ (special-memory-instruction MB #x4000) ; Memory barrier
+ (special-memory-instruction-Ra RC #xE000) ; Read and clear (VAX converter)
+ (special-memory-instruction-Ra RPCC #xC000) ; Read process cycle counter
+ (special-memory-instruction-Ra RS #xF000) ; Read and set (VAX converter)
+ (special-memory-instruction TRAPB #x0000) ; Trap barrier
+)
+\f
+(let-syntax
+ ((operate-format
+ (macro (keyword opcode functioncode)
+ `(define-instruction ,keyword
+ (((? source-1) (& (? constant)) (? destination))
+ (LONG (6 ,opcode)
+ (5 source-1)
+ (8 constant UNSIGNED)
+ (1 1) ; Must be one
+ (7 ,functioncode)
+ (5 destination)))
+ (((? source-1) (? source-2) (? destination))
+ (LONG (6 ,opcode)
+ (5 source-1)
+ (5 source-2)
+ (3 0) ; Should be zero
+ (1 0) ; Must be zero
+ (7 ,functioncode)
+ (5 destination)))))))
+ (operate-format ADDL #x10 #x00) ; Add longword
+ (operate-format ADDLV #x10 #x40) ; Add longword, enable oflow trap
+ (operate-format ADDQ #x10 #x20) ; Add quadword
+ (operate-format ADDQV #x10 #x60) ; Add quadword, enable oflow trap
+ (operate-format AND #x11 #x00) ; Logical product
+ (operate-format BIC #x11 #x08) ; Bit clear
+ (operate-format BIS #x11 #x20) ; Bit set (logical sum, OR)
+ (operate-format CMOVEQ #x11 #x24) ; Rc <- Rb if Ra = 0
+ (operate-format CMOVGE #x11 #x46) ; Rc <- Rb if Ra >= 0
+ (operate-format CMOVGT #x11 #x66) ; Rc <- Rb if Ra > 0
+ (operate-format CMOVLBC #x11 #x16) ; Rc <- Rb if Ra low bit clear
+ (operate-format CMOVLBS #x11 #x14) ; Rc <- Rb if Ra low bit set
+ (operate-format CMOVLE #x11 #x64) ; Rc <- Rb if Ra <= 0
+ (operate-format CMOVLT #x11 #x44) ; Rc <- Rb if Ra < 0
+ (operate-format CMOVNE #x11 #x26) ; Rc <- Rb if Ra != 0
+ (operate-format CMPBGE #x10 #x0f) ; Compare 8 bytes in parallel
+ (operate-format CMPEQ #x10 #x2d) ; Compare quadwords for equal
+ (operate-format CMPLE #x10 #x6d) ; Compare quadwords for <=
+ (operate-format CMPLT #x10 #x4d) ; Compare quadwords for <
+ (operate-format CMPULE #x10 #x3d) ; Unsigned compare quadwords for <=
+ (operate-format CMPULT #x10 #x1d) ; Unsigned compare quadwords for <
+ (operate-format EQV #x11 #x48) ; Bitwise logical equivalence
+ (operate-format EXTBL #x12 #x06) ; Extract byte low
+ (operate-format EXTLH #x12 #x6a) ; Extract longword high
+ (operate-format EXTLL #x12 #x26) ; Extract longword low
+ (operate-format EXTQH #x12 #x7a) ; Extract quadword high
+ (operate-format EXTQL #x12 #x36) ; Extract quadword low
+ (operate-format EXTWH #x12 #x5a) ; Extract word high
+ (operate-format EXTWL #x12 #x16) ; Extract word low
+ (operate-format INSBL #x12 #x0b) ; Insert byte low
+ (operate-format INSLH #x12 #x67) ; Insert longword high
+ (operate-format INSLL #x12 #x2b) ; Insert longword low
+ (operate-format INSQH #x12 #x77) ; Insert quadword high
+ (operate-format INSQL #x12 #x3b) ; Insert quadword low
+ (operate-format INSWH #x12 #x57) ; Insert word high
+ (operate-format INSWL #x12 #x1b) ; Insert word low
+ (operate-format MSKBL #x12 #x02) ; Mask byte low
+ (operate-format MSKLH #x12 #x62) ; Mask longword high
+ (operate-format MSKLL #x12 #x22) ; Mask longword low
+ (operate-format MSKQH #x12 #x72) ; Mask quadword high
+ (operate-format MSKQL #x12 #x32) ; Mask quadword low
+ (operate-format MSKWH #x12 #x52) ; Mask word high
+ (operate-format MSKWL #x12 #x12) ; Mask word low
+ (operate-format MULL #x13 #x00) ; Multiply longword
+ (operate-format MULLV #x13 #x40) ; Multiply longword, enable oflow trap
+ (operate-format MULQ #x13 #x20) ; Multiply quadword
+ (operate-format MULQV #x13 #x60) ; Multiply quadword, enable oflow trap
+ (operate-format ORNOT #x11 #x28) ; Ra v ~Rb
+ (operate-format S4ADDL #x10 #x02) ; Shift Ra by 4 and longword add to Rb
+ (operate-format S4ADDQ #x10 #x22) ; Shift Ra by 4 and quadword add to Rb
+ (operate-format S4SUBL #x10 #x0b) ; Shift Ra and longword subtract Rb
+ (operate-format S4SUBQ #x10 #x2b) ; Shift Ra and quadword subtract Rb
+ (operate-format S8ADDL #x10 #x12) ; Shift Ra by 8 and longword add to Rb
+ (operate-format S8ADDQ #x10 #x32) ; Shift Ra by 8 and quadword add to Rb
+ (operate-format S8SUBL #x10 #x1b) ; Shift Ra and longword subtract Rb
+ (operate-format S8SUBQ #x10 #x3b) ; Shift Ra and quadword subtract Rb
+ (operate-format SLL #x12 #x39) ; Shift left logical
+ (operate-format SRA #x12 #x3c) ; Shift right arithmetic
+ (operate-format SRL #x12 #x34) ; Shift right logical
+ (operate-format SUBL #x10 #x09) ; Subtract longword
+ (operate-format SUBLV #x10 #x49) ; Subtract longword, enable oflow trap
+ (operate-format SUBQ #x10 #x29) ; Subtract quadword
+ (operate-format SUBQV #x10 #x69) ; Subtract quadword, enable oflow trap
+ (operate-format UMULH #x13 #x30) ; Unsigned multiply quadword high
+ (operate-format XOR #x11 #x40) ; Logical difference (xor)
+ (operate-format ZAP #x12 #x30) ; Zero bytes
+ (operate-format ZAPNOT #x12 #x31) ; Zero bytes not
+)
+
+(let-syntax
+ ((pal-format
+ (macro (keyword functioncode)
+ `(define-instruction ,keyword
+ (()
+ (LONG (6 0)
+ (26 ,functioncode)))))))
+
+ (pal-format BPT #x0080) ; Initiate program debugging
+ (pal-format BUGCHK #x0081) ; Initiate program exception
+ (pal-format CHME #x0082) ; Change mode to emulator
+ (pal-format CHMK #x0083) ; Change mode to kernel
+ (pal-format CHMS #x0084) ; Change mode to supervisor
+ (pal-format CHMU #x0085) ; Change mode to user
+ (pal-format IMB #x0086) ; Instruction memory barrier
+ (pal-format INSQHIL #x0087) ; Insert into longword queue at head, interlocked
+ (pal-format INSQHIQ #x0089) ; ... quadword ... head
+ (pal-format INSQTIL #x0088) ; ... longword ... tail
+ (pal-format INSQTIQ #x008a) ; ... quadword ... tail
+ (pal-format INSQUEL #x008b) ; Insert into longword queue
+ (pal-format INSQUELD #x008d) ;
+ (pal-format INSQUEQ #x008c) ; Insert into quadword queue
+ (pal-format INSQUEQD #x008e) ;
+ (pal-format PROBER #x008f) ; Probe for read access
+ (pal-format PROBEW #x0090) ; Probe for write access
+ (pal-format RD_PS #x0091) ; Move processor status
+ (pal-format REI #x0092) ; Return from exception or interrupt
+ (pal-format REMQHIL #x0093) ; Remove from longword queue at head, interlocked
+ (pal-format REMQHIQ #x0095) ; ... quadword ... head
+ (pal-format REMQTIL #x0094) ; ... longword ... tail
+ (pal-format REMQTIQ #x0096) ; ... quadword ... tail
+ (pal-format REMQUEL #x0097) ; Remove from longword queue
+ (pal-format REMQUELD #x0099) ;
+ (pal-format REMQUEQ #x0098) ; Remove from quadword queue
+ (pal-format REMQUEQD #x009a) ;
+ (pal-format RSCC #x009d) ;
+ (pal-format SWASTEN #x009b) ; Swap AST enable
+ (pal-format WR_PS_SW #x009c) ; Write processor status s'ware field
+
+ ;; Privileged PALcode instructions.
+ (pal-format HALT #x0000)
+)
+\f
+;;;; Assembler pseudo-ops
+
+(define-instruction EXTERNAL-LABEL
+ ;; External labels provide the garbage collector with header
+ ;; information and the runtime system with type, arity, and
+ ;; debugging information.
+ (((? format-word) (@PCR (? label)))
+ (LONG (16 label BLOCK-OFFSET)
+ (16 format-word UNSIGNED))))
+
+(define-instruction NOP
+ ;; BIS R31 R31 R31
+ (()
+ (LONG (6 #x11) (5 31) (5 31) (3 0) (1 0) (7 #x20) (5 31))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: instr2.scm,v 1.1 1992/08/29 13:51:24 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; Alpha instruction set, part 2
+;;; Instructions that require branch tensioning
+;;; Package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+; Unconditional jump instructions
+(let-syntax
+ ((memory-branch
+ (macro (keyword hint)
+ `(define-instruction ,keyword
+ (((? link-register) (? base))
+ (LONG (6 #x1a)
+ (5 link-register)
+ (5 base)
+ (2 ,hint)
+ (14 0 SIGNED)))
+ (((? base))
+ (LONG (6 #x1a)
+ (5 regnum:came-from)
+ (5 base)
+ (2 ,hint)
+ (14 0 SIGNED)))
+ (((? link-register) (? base) (@PCR (? probable-target)))
+ (LONG (6 #x1a)
+ (5 link-register)
+ (5 base)
+ (2 ,hint)
+ (14 `(/ (remainder (- ,probable-target (+ *PC* 4))
+ #x10000)
+ 4)
+ SIGNED)))
+ (((? link-register) (? base) (@PCO (? probable-target-address)))
+ (LONG (6 #x1a)
+ (5 link-register)
+ (5 base)
+ (2 ,hint)
+ (14 `(/ (remainder ,probable-target-address
+ #x10000)
+ 4)
+ SIGNED)))))))
+ (memory-branch JMP #x0)
+ (memory-branch JSR #x1)
+ (memory-branch RET #x2)
+ (memory-branch COROUTINE #x3))
+
+; Conditional branch instructions
+
+(let-syntax
+ ((branch
+ (macro (keyword opcode reverse-op)
+ `(define-instruction ,keyword
+ (((? reg) (@PCO (? offset)))
+ (LONG (6 ,opcode)
+ (5 reg)
+ (21 (quotient offset 4) SIGNED)))
+ (((? reg) (@PCR (? label)))
+ (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4))
+ ((#x-100000 #xFFFFF)
+ (LONG (6 ,opcode)
+ (5 reg)
+ (21 offset SIGNED)))
+ ((#x-1FFFFFFE #x20000001)
+ ;; -1: <reverse> xxx
+ ;; 0: LDAH temp, left[4*(offset-2)](R31)
+ ;; +1: BR link, yyy
+ ;; 2: yyy: ADDQ temp, link, temp
+ ;; 3: LDA temp, right[4*(offset-2)](temp)
+ ;; 4: JMP came_from, temp, hint
+ ;; 5: xxx:
+ (LONG (6 ,reverse-op) ; reverse branch to (.+1)+4
+ (5 reg) ; register
+ (21 5 SIGNED) ; offset = +5 instructions
+ (6 #x09) ; LDAH
+ (5 regnum:assembler-temp) ; destination = temp
+ (5 31) ; base = zero
+ (16 (adjusted:high (* (- offset 2) 4)) SIGNED)
+ (6 #x30) ; BR
+ (5 26) ; return address to link
+ (21 0 SIGNED) ; (.+4) + 0
+ (6 #x10) ; ADDQ
+ (5 regnum:assembler-temp) ; source = temp
+ (5 26) ; source = link
+ (3 0) ; should be 0
+ (1 0) ; must be 0
+ (7 #x20) ; function=ADDQ
+ (5 regnum:assembler-temp) ; destination = temp
+ (6 #x08) ; LDA
+ (5 regnum:assembler-temp) ; destination = temp
+ (5 regnum:assembler-temp) ; base = temp
+ (16 (adjusted:low (* (- offset 2) 4)) SIGNED)
+ (6 #x1a) ; JMP
+ (5 regnum:assembler-temp) ; return address to "came from"
+ (5 regnum:assembler-temp) ; base = temp
+ (2 #x0) ; jump hint
+ (14 (/ (adjusted:low (* (- offset 5) 4)) 4)
+ SIGNED)))))))))
+ (branch beq #x39 #x3d)
+ (branch bge #x3e #x3a)
+ (branch bgt #x3f #x3b)
+ (branch blbc #x38 #x3c)
+ (branch blbs #x3c #x38)
+ (branch ble #x3b #x3f)
+ (branch blt #x3a #x3e)
+ (branch bne #x3d #x39)
+ (branch fbeq #x31 #x35)
+ (branch fbge #x36 #x32)
+ (branch fbgt #x37 #x33)
+ (branch fble #x33 #x37)
+ (branch fblt #x32 #x36)
+ (branch fbne #x35 #x31))
+
+; Unconditional branch instructions
+
+(let-syntax
+ ((unconditional-branch
+ (macro (keyword opcode hint)
+ `(define-instruction ,keyword
+ (((? reg) (@PCO (? offset)))
+ (LONG (6 ,opcode)
+ (5 reg)
+ (21 (quotient offset 4) SIGNED)))
+ (((? reg) (@PCR (? label)))
+ (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4))
+ ((#x-100000 #xFFFFF)
+ (LONG (6 ,opcode)
+ (5 reg)
+ (21 offset SIGNED)))
+ ((#x-1FFFFFFF #x20000000)
+ ;; -1: LDAH temp, left[4*(offset-1)](R31)
+ ;; 0: BR link, yyy
+ ;; 1: yyy: ADDQ temp, link, temp
+ ;; 2: LDA temp, right[4*(offset-1)](temp)
+ ;; 3: JMP came_from, temp, hint
+ ;; 4: xxx:
+ (LONG (6 #x09) ; LDAH
+ (5 regnum:assembler-temp) ; destination = temp
+ (5 31) ; base = zero
+ (16 (adjusted:high (* (- offset 1) 4)) SIGNED)
+ (6 #x30) ; BR
+ (5 26) ; return address to link
+ (21 0 SIGNED) ; (.+4) + 0
+ (6 #x10) ; ADDQ
+ (5 regnum:assembler-temp) ; source = temp
+ (5 26) ; source = link
+ (3 0) ; should be 0
+ (1 0) ; must be 0
+ (7 #x20) ; function=ADDQ
+ (5 regnum:assembler-temp) ; destination = temp
+ (6 #x08) ; LDA
+ (5 regnum:assembler-temp) ; destination = temp
+ (5 regnum:assembler-temp) ; base = temp
+ (16 (adjusted:low (* (- offset 1) 4)) SIGNED)
+ (6 #x1a) ; JMP
+ (5 reg) ; return address register
+ (5 regnum:assembler-temp) ; base = temp
+ (2 ,hint) ; jump hint
+ (14 (/ (adjusted:low (* (- offset 4) 4)) 4) SIGNED)))))
+ (((? reg) (OFFSET (? offset) (@PCR (? label))))
+ (VARIABLE-WIDTH (offset `(/ (- (+ ,offset ,label)
+ (+ *PC* 4))
+ 4))
+ ((#x-100000 #xFFFFF)
+ (LONG (6 ,opcode)
+ (5 reg)
+ (21 offset SIGNED)))
+ ((#x-1FFFFFFF #x20000000)
+ ;; -1: LDAH temp, left[4*(offset-1)](R31)
+ ;; 0: BR link, yyy
+ ;; 1: yyy: ADDQ temp, link, temp
+ ;; 2: LDQ temp, right[4*(offset-1)]
+ ;; 2: JMP came_from, temp, hint
+ (LONG (6 #x09) ; LDAH
+ (5 regnum:assembler-temp) ; destination = temp
+ (5 31) ; base = zero
+ (16 (adjusted:high (* (- offset 1) 4)) SIGNED)
+ (6 #x30) ; BR
+ (5 26) ; return address to link
+ (21 0 SIGNED) ; (.+4) + 0
+ (6 #x10) ; ADDQ
+ (5 regnum:assembler-temp) ; source = temp
+ (5 26) ; source = link
+ (3 0) ; should be 0
+ (1 0) ; must be 0
+ (7 #x20) ; function=ADDQ
+ (5 regnum:assembler-temp) ; destination = temp
+ (6 #x08) ; LDA
+ (5 regnum:assembler-temp) ; destination = temp
+ (5 regnum:assembler-temp) ; base = temp
+ (16 (adjusted:low (* (- offset 1) 4)) SIGNED)
+ (6 #x1a) ; JMP
+ (5 reg) ; return address register
+ (5 regnum:assembler-temp) ; base = temp
+ (2 ,hint) ; jump hint
+ (14 (/ (adjusted:low (* (- offset 4) 4)) 4)
+ SIGNED)))))))))
+ (unconditional-branch br #x30 #x0)
+ (unconditional-branch bsr #x34 #x1))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: instr3.scm,v 1.1 1992/08/29 13:51:25 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; Alpha instruction set, part 3
+;;; Floating point instructions
+;;; Package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define (encode-fp-qualifier qualifier)
+ (define (translate symbol)
+ (case symbol
+ ((C) #x-080) ; Chopped (round toward 0)
+ ((M) #x-040) ; Round to minus infinity
+ ((D) #x040) ; Round from state bits (dynamic)
+ ((U) #x100) ; Underflow enabled
+ ((V) #x100) ; Integer overflow enabled (CVTTQ only)
+ ((I) #x200) ; Inexact enabled
+ ((S) #x400) ; Software
+ (else (error "ENCODE-FP-QUALIFIER: unknown qualifier" symbol))))
+ (if (symbol? qualifier)
+ (translate qualifier)
+ (apply + (map translate qualifier))))
+
+(let-syntax
+ ((floating-operate
+ (macro (keyword function-code)
+ `(define-instruction ,keyword
+ (((? src-1) (? src-2) (? dest))
+ (LONG (6 #x17) ; Opcode
+ (5 src-1)
+ (5 src-2)
+ (11 ,function-code)
+ (5 dest)))))))
+ (floating-operate CPYS #x20)
+ (floating-operate CPYSE #x22)
+ (floating-operate CPYSN #x21)
+ (floating-operate CVTLQ #x10)
+ (floating-operate CVTQL #x30)
+ (floating-operate CVTQLSV #x330)
+ (floating-operate CVTQLV #x130)
+ (floating-operate FCMOVEQ #x2a)
+ (floating-operate FCMOVGE #x2d)
+ (floating-operate FCMOVGT #x2f)
+ (floating-operate FCMOVLE #x2e)
+ (floating-operate FCMOVLT #x2c)
+ (floating-operate FCMOVNE #x2b)
+ (floating-operate MF_FPCR #x25)
+ (floating-operate MT_FPCR #x24))
+
+(let-syntax
+ ((ieee
+ (macro (keyword function-code)
+ `(define-instruction ,keyword
+ (((? src-1) (? src-2) (? dest))
+ (LONG (6 #x16) ; Opcode
+ (5 src-1)
+ (5 src-2)
+ (11 ,function-code)
+ (5 dest)))
+ ((/ (? qualifier) (? src-1) (? src-2) (? dest))
+ (LONG (6 #x16) ; Opcode
+ (5 src-1)
+ (5 src-2)
+ (11 (+ ,function-code (encode-fp-qualifier qualifier)))
+ (5 dest)))))))
+ (ieee ADDS #x80)
+ (ieee ADDT #xA0)
+ (ieee CMPTEQ #xA5)
+ (ieee CMPTLE #xA7)
+ (ieee CMPTLT #xA6)
+ (ieee CMPTUN #xA4)
+ (ieee CVTQS #xBC)
+ (ieee CVTQT #xBE)
+ (ieee CVTTQ #xAF)
+ (ieee CVTTS #xAC)
+ (ieee DIVS #x83)
+ (ieee DIVT #xA3)
+ (ieee MULS #x82)
+ (ieee MULT #xA2)
+ (ieee SUBS #x81)
+ (ieee SUBT #xA1))
+
+(let-syntax
+ ((vax
+ (macro (keyword function-code)
+ `(define-instruction ,keyword
+ (((? src-1) (? src-2) (? dest))
+ (LONG (6 #x15) ; Opcode
+ (5 src-1)
+ (5 src-2)
+ (11 ,function-code)
+ (5 dest)))
+ ((/ (? qualifier) (? src-1) (? src-2) (? dest))
+ (LONG (6 #x15) ; Opcode
+ (5 src-1)
+ (5 src-2)
+ (11 (+ ,function-code (encode-fp-qualifier qualifier)))
+ (5 dest)))))))
+ (vax ADDF #x80)
+ (vax ADDG #xa0)
+ (vax CMPGEQ #xa5)
+ (vax CMPGLE #xa7)
+ (vax CMPGLT #xa6)
+ (vax CVTDG #x9e)
+ (vax CVTGD #xad)
+ (vax CVTGF #xac)
+ (vax CVTGQ #xaf)
+ (vax CVTQF #xbc)
+ (vax CVTQG #xbe)
+ (vax DIVF #x83)
+ (vax DIVG #xa3)
+ (vax MULF #xb2)
+ (vax MULG #x81)
+ (vax SUBF #x81)
+ (vax SUBG #xa1))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: lapgen.scm,v 1.1 1992/08/29 13:51:26 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; RTL Rules for Alpha. Shared utilities.
+;; Package: (compiler lap-syntaxer)
+;; Syntax: lap-generator-syntax-table
+
+(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 8-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
+ ;; r0 -- return value
+ r1 ;; -- utility index
+ ;; r2 -- stack pointer
+ ;; r3 -- memtop
+ ;; r4 -- free
+ ;; r5 -- dynamic link
+ r6 r7 r8
+ ;; r9 -- register pointer
+ ;; r10 -- scheme-to-interface
+ ;; r11 -- closure hook
+ ;; r12 -- scheme-to-interface-jsr
+ ;; r13 -- compiled-entry type bits
+ ;; r14 -- closure free
+ r15 r16 r17 r18 r19 r20 r21 r22 r23 r24 r25 r26 r27
+ ;; r28 -- assembler temp / came from
+ r29
+ ;; r30 -- C stack pointer
+ ;; r31 -- ZERO
+ f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15
+ f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 f27 f28
+ f29 f30
+ ;; f31 -- ZERO.
+ ))
+
+(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
+ '#(; 0 1 2 3 4 5 6 7
+ 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
+ ; Needed by standard-register-reference in lapgn2
+ (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 64)
+ (begin
+ (vector-set! references register (INST-EA (FPR ,fpr)))
+ (loop (1+ register) (1+ fpr)))))
+ (lambda (register)
+ (vector-ref references register))))
+\f
+;;;; Utilities for the rules
+
+(define (require-register! machine-reg)
+ (flush-register! machine-reg)
+ (need-register! machine-reg))
+
+(define-integrable (flush-register! machine-reg)
+ (prefix-instructions! (clear-registers! machine-reg)))
+
+(define (rtl-target:=machine-register! rtl-reg machine-reg)
+ (if (machine-register? rtl-reg)
+ (begin
+ (require-register! machine-reg)
+ (if (not (= rtl-reg machine-reg))
+ (suffix-instructions!
+ (register->register-transfer machine-reg rtl-reg))))
+ (begin
+ (delete-register! rtl-reg)
+ (flush-register! machine-reg)
+ (add-pseudo-register-alias! rtl-reg machine-reg))))
+
+;;;; Useful Cliches
+
+(define (memory->register-transfer offset base target)
+ (case (register-type target)
+ ((GENERAL) (LAP (LDQ ,target (OFFSET ,offset ,base))))
+ ((FLOAT) (fp-load-doubleword offset base target))
+ (else (error "unknown register type" target))))
+
+(define (register->memory-transfer source offset base)
+ (case (register-type source)
+ ((GENERAL) (LAP (STQ ,source (OFFSET ,offset ,base))))
+ ((FLOAT) (fp-store-doubleword offset base source))
+ (else (error "unknown register type" source))))
+
+(define (load-constant target constant record?)
+ ;; Load a Scheme constant into a machine register.
+ (if (non-pointer-object? constant)
+ (load-immediate target (non-pointer->literal constant) record?)
+ (load-pc-relative target
+ 'CONSTANT
+ (constant->label constant))))
+
+(define (deposit-type-address type source target)
+ (if (= type (ucode-type compiled-entry))
+ (LAP (BIS ,regnum:compiled-entry-type-bits ,source ,target))
+ (deposit-type-datum type source target)))
+
+(define (deposit-type-datum type source target)
+ (with-values
+ (lambda ()
+ (immediate->register (make-non-pointer-literal type 0)))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ (BIS ,alias ,source ,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))
+\f
+;;;; Regularized Machine Instructions
+
+(define-integrable (fits-in-8-bits-unsigned? value)
+ (<= #x0 value #xff))
+
+(define-integrable (fits-in-16-bits-signed? value)
+ (<= #x-8000 value #x7fff))
+
+(define-integrable (fits-in-16-bits-unsigned? value)
+ (<= #x0 value #xffff))
+
+(define-integrable (fits-in-32-bits-signed? value)
+ (fits-in-16-bits-signed? (quotient value #x10000)))
+
+(define (top-16-of-32-bits-only? value)
+ (let ((result (integer-divide value #x10000)))
+ (and (zero? (integer-divide-remainder result))
+ (fits-in-16-bits-signed? (integer-divide-quotient result)))))
+
+; The adjustments are only good when n is 32 bits long.
+
+(define (adjusted:high n)
+ (let ((n (->unsigned n 32)))
+ (if (< (remainder n #x10000) #x8000)
+ (->signed (quotient n #x10000) 16)
+ (->signed (+ (quotient n #x10000) 1) 16))))
+
+(define (adjusted:low n)
+ (let ((remainder (remainder (->unsigned n 32) #x10000)))
+ (if (< remainder #x8000)
+ remainder
+ (- remainder #x10000))))
+
+(define (split-64-bits n)
+ (let* ((n (->unsigned n 64))
+ (split (integer-divide n #x100000000)))
+ (if (< (integer-divide-remainder split) #x80000000)
+ (values (->signed (integer-divide-quotient split) 32)
+ (->signed (integer-divide-remainder split) 32))
+ (values (->signed (1+ (integer-divide-quotient split)) 32)
+ (->signed (- (integer-divide-remainder split) #x100000000)
+ 32)))))
+
+(define (->unsigned n nbits)
+ (if (negative? n)
+ (+ (expt 2 nbits) n)
+ n))
+
+(define (->signed n nbits)
+ (if (>= n (expt 2 (- nbits 1)))
+ (- n (expt 2 nbits))
+ n))
+
+(define (copy r t)
+ (if (= r t)
+ (LAP)
+ (LAP (COPY ,r ,t))))
+
+(define (fp-copy from to)
+ (if (= to from)
+ (LAP)
+ (LAP (CPYS ,(float-register->fpr from)
+ ,(float-register->fpr from)
+ ,(float-register->fpr to)))))
+
+(define (fp-load-doubleword offset base target)
+ (LAP (LDT ,(float-register->fpr target)
+ (OFFSET ,offset ,base))))
+
+(define (fp-store-doubleword offset base source)
+ (LAP (STT ,(float-register->fpr source)
+ (OFFSET ,offset ,base))))
+\f
+;;;; PC-relative addresses
+
+(define (load-pc-relative target type label)
+ ;; Load a pc-relative location's contents into a machine register.
+ ;; Optimization: if there is a register that contains the value of
+ ;; another label, use that register as the base register.
+ ;; Otherwise, allocate a temporary and load it with the value of the
+ ;; label, then use the temporary as the base register. This
+ ;; strategy of loading a temporary wins if the temporary is used
+ ;; again, but loses if it isn't, since loading the temporary takes
+ ;; one instruction in addition to the LDQ instruction, while doing a
+ ;; pc-relative LDQ instruction takes only two instructions total.
+ ;; But pc-relative loads of various kinds are quite common, so this
+ ;; should almost always be advantageous.
+ (with-values (lambda () (get-typed-label type))
+ (lambda (label* alias type-of-label*)
+ (cond ((not label*) ; No labels of any kind
+ (let ((temporary (standard-temporary!))
+ (here (generate-label)))
+ (set-typed-label! 'CODE here temporary)
+ (LAP (BR ,temporary (@PCO 0))
+ (LABEL ,here)
+ ,@(if (eq? type 'CODE)
+ (LAP (LDQ ,target
+ (OFFSET (- ,label ,here) ,temporary)))
+ (let ((temp2 (standard-temporary!)))
+ (set-typed-label! type label temp2)
+ (LAP (LDA ,temp2
+ (OFFSET (- ,label ,here) ,temporary))
+ (LDQ ,target (OFFSET 0 ,temp2))))))))
+ ((eq? type type-of-label*) ; We got what we wanted
+ (LAP (LDQ ,target (OFFSET (- ,label ,label*) ,alias))))
+ ((eq? type 'CODE) ; Cheap to generate
+ (let ((temporary (standard-temporary!))
+ (here (generate-label)))
+ (set-typed-label! 'CODE here temporary)
+ (LAP (BR ,temporary (@PCO 0))
+ (LABEL ,here)
+ (LDQ ,target (OFFSET (- ,label ,here) ,temporary)))))
+ (else ; Wrong type of label, and what
+ ; we need may be expensive
+ (let ((temporary (standard-temporary!)))
+ (set-typed-label! type label temporary)
+ (LAP (LDA ,temporary (OFFSET (- ,label ,label*) ,alias))
+ (LDQ ,target (OFFSET 0 ,temporary)))))))))
+
+(define (load-pc-relative-address target type label)
+ ;; Load address of a pc-relative location into a machine register.
+ ;; Optimization: if there is another register that contains the
+ ;; value of another label, add the difference between the labels to
+ ;; that register's contents instead. The ADDI takes one
+ ;; instruction, while the %LOAD-PC-RELATIVE-ADDRESS takes two, so
+ ;; this is always advantageous.
+ ;;
+ ;; IMPORTANT: the target can't be clobbered by the current RTL rule
+ ;; (except by this code) since we are remembering its contents in
+ ;; the register map. This implies that the rule better not be
+ ;; matching target with a machine register (use pseudo-register? to
+ ;; test it).
+ (with-values (lambda () (get-typed-label type))
+ (lambda (label* alias type-of-label*)
+ (cond ((not label*) ; No labels of any kind
+ (let ((temporary (standard-temporary!))
+ (here (generate-label)))
+ (set-typed-label! 'CODE here temporary)
+ (if (not (eq? type 'CODE))
+ (set-typed-label! type label target))
+ (LAP (BR ,temporary (@PCO 0))
+ (LABEL ,here)
+ (LDA ,target
+ (OFFSET (- ,label ,here) ,temporary)))))
+ ((eq? type type-of-label*) ; We got what we wanted
+ (LAP (LDA ,target (OFFSET (- ,label ,label*) ,alias))))
+ ((eq? type 'CODE) ; Cheap to generate
+ (let ((temporary (standard-temporary!))
+ (here (generate-label)))
+ (set-typed-label! 'CODE here temporary)
+ (LAP (BR ,temporary (@PCO 0))
+ (LABEL ,here)
+ (LDA ,target (OFFSET (- ,label ,here) ,temporary)))))
+ (else ; Wrong type of label, and what
+ ; we need may be expensive
+ (set-typed-label! type label target)
+ (LAP (LDA ,target (OFFSET (- ,label ,label*) ,alias))))))))
+
+;;; Typed labels provide further optimization. There are two types,
+;;; CODE and CONSTANT, that say whether the label is located in the
+;;; code block or the constants block of the output. Statistically,
+;;; a label is likely to be closer to another label of the same type
+;;; than to a label of the other type.
+
+(define (get-typed-label type)
+ (let ((entries (register-map-labels *register-map* 'GENERAL)))
+ (let loop ((entries* entries))
+ (cond ((null? entries*)
+ ;; If no entries of the given type, use any entry that is
+ ;; available.
+ (let loop ((entries entries))
+ (cond ((null? entries)
+ (values false false false))
+ ((pair? (caar entries))
+ (values (cdaar entries) (cadar entries) (caaar entries)))
+ (else
+ (loop (cdr entries))))))
+ ((and (pair? (caar entries*))
+ (eq? type (caaar entries*)))
+ (values (cdaar entries*) (cadar entries*) type))
+ (else
+ (loop (cdr entries*)))))))
+
+(define (set-typed-label! type label alias)
+ (set! *register-map*
+ (set-machine-register-label *register-map* alias (cons type label)))
+ unspecific)
+\f
+(define (immediate->register immediate)
+ (with-values (lambda () (get-immediate-alias immediate))
+ (lambda (register bumper) ; Bumper = #T -> exact hit
+ (cond ((not register)
+ (let* ((temporary (standard-temporary!))
+ (code (%load-immediate temporary immediate)))
+ (set! *register-map*
+ (set-machine-register-label *register-map*
+ temporary
+ immediate))
+ (values code temporary)))
+ ((eq? bumper #T) (values (LAP) register))
+ (else
+ (let* ((temporary (standard-temporary!))
+ (code (bumper register temporary)))
+ (set! *register-map*
+ (set-machine-register-label *register-map*
+ temporary
+ immediate))
+ (values code temporary)))))))
+
+(define (bump old-value desired-value)
+ (define (zappable? old new)
+ (do ((i 8
+ (- i 1))
+ (old (->unsigned old 64)
+ (quotient old 256))
+ (new (->unsigned new 64)
+ (quotient new 256))
+ (bit 1
+ (* bit 2))
+ (mask 0
+ (let ((old (remainder old 256))
+ (new (remainder new 256)))
+ (cond ((= old new) mask)
+ ((zero? new) (+ mask bit))
+ (else #F)))))
+ ((or (not mask) (= i 0)) mask)))
+
+ (define (differs-in-contiguous-bits? old-value desired-value)
+ ; 16 bits at the top end, 15 bits elsewhere
+ (let ((difference-bits
+ (bit-string-xor
+ (signed-integer->bit-string 64 old-value)
+ (signed-integer->bit-string 64 desired-value))))
+ (let ((low-differing-bit
+ (bit-substring-find-next-set-bit
+ difference-bits 0 64)))
+ (cond ((not low-differing-bit) (values #F #F))
+ ((>= low-differing-bit 48)
+ (values (bit-string->signed-integer
+ (bit-substring difference-bits 48 64))
+ 48))
+ ((bit-substring-find-next-set-bit
+ difference-bits (+ low-differing-bit 15)
+ 64)
+ (values #F #F))
+ (else
+ (values (bit-string->unsigned-integer
+ (bit-substring difference-bits
+ low-differing-bit
+ (+ low-differing-bit 15)))
+ low-differing-bit))))))
+
+ (define (try-high-and-low value)
+ (let ((bits (signed-integer->bit-string 64 value)))
+ (let ((low-16 (bit-string->signed-integer
+ (bit-substring bits 0 16))))
+ (if (not (= low-16 (bit-string->signed-integer
+ (bit-substring bits 0 48))))
+ (values false false)
+ (let* ((high-16 (bit-string->signed-integer
+ (bit-substring bits 48 64)))
+ (adjusted (cond ((not (negative? low-16)) high-16)
+ ((= high-16 #x7FFF) #x-8000)
+ (else (+ high-16 1)))))
+ (values 3
+ (lambda (source target)
+ source ; ignored
+ (LAP (MOVEI ,target (& ,adjusted))
+ (SLL ,target (& 48) ,target)
+ (LDA ,target (OFFSET ,low-16 ,target))))))))))
+
+ (let ((desired-value (->signed desired-value 64))
+ (old-value (->signed old-value 64)))
+ (let ((delta (- desired-value old-value)))
+ (cond ((fits-in-16-bits-signed? delta)
+ (values 1
+ (lambda (source target)
+ (LAP (LDA ,target (OFFSET ,delta ,source))))))
+ ((top-16-of-32-bits-only? delta)
+ (values 1
+ (lambda (source target)
+ (LAP (LDAH ,target (OFFSET ,(quotient delta #x10000)
+ ,source))))))
+ ((eqv? old-value (- desired-value))
+ (values 1
+ (lambda (source target)
+ (LAP (SUBQ ,regnum:zero ,source ,target)))))
+ ((eqv? desired-value (- (+ 1 old-value)))
+ (values 1
+ (lambda (source target)
+ (LAP (EQV ,regnum:zero ,source ,target)))))
+ ((zappable? old-value desired-value)
+ => (lambda (mask)
+ (values 1
+ (lambda (source target)
+ (LAP (ZAP ,source (& ,mask) ,target))))))
+ ((fits-in-32-bits-signed? delta)
+ (values 2
+ (lambda (source target)
+ (LAP (LDA ,target (OFFSET ,(adjusted:low delta) ,source))
+ (LDAH ,target (OFFSET ,(adjusted:high delta)
+ ,target))))))
+ (else
+ (with-values
+ (lambda ()
+ (differs-in-contiguous-bits? old-value desired-value))
+ (lambda (constant shift)
+ (cond ((and (not constant) (eqv? old-value 0))
+ (try-high-and-low desired-value))
+ ((not constant) (values #F #F))
+ ((eqv? old-value 0)
+ (values 2
+ (lambda (source target)
+ source ; Unused
+ (LAP (MOVEI ,target (& ,constant))
+ (SLL ,target (& ,shift) ,target)))))
+ (else
+ (values 3
+ (lambda (source target)
+ source ; Unused
+ (LAP
+ (MOVEI ,target (& ,constant))
+ (SLL ,target (& ,shift) ,target)
+ (XOR ,target ,source ,target)))))))))))))
+
+(define (get-immediate-alias immediate)
+ (let loop ((entries
+ (cons (list 0 regnum:zero)
+ (register-map-labels *register-map* 'GENERAL)))
+ (best-bumper #T)
+ (least-cost #F)
+ (best-register #F))
+ (cond ((null? entries)
+ (values best-register best-bumper))
+ ((eqv? (caar entries) immediate)
+ (values (cadar entries) #T)) ; Exact match
+ ((not (number? (caar entries)))
+ (loop (cdr entries) best-bumper least-cost best-register))
+ (else
+ (with-values (lambda () (bump (caar entries) immediate))
+ (lambda (cost bumper)
+ (cond ((not cost)
+ (loop (cdr entries) best-bumper
+ least-cost best-register))
+ ((or (not least-cost) (< cost least-cost))
+ (loop (cdr entries) bumper
+ cost (cadar entries)))
+ (else (loop (cdr entries) best-bumper
+ least-cost best-register)))))))))
+
+(define (load-immediate target immediate record?)
+ (let ((registers (get-immediate-aliases immediate)))
+ (cond ((memv target registers)
+ (LAP))
+ ((not (null? registers))
+ (if record?
+ (set! *register-map*
+ (set-machine-register-label *register-map*
+ target
+ immediate)))
+ (LAP (COPY ,(car registers) ,target)))
+ (else
+ (with-values (lambda () (get-immediate-alias immediate))
+ (lambda (register bumper)
+ (let ((result
+ (if register
+ (bumper register target)
+ (%load-immediate target immediate))))
+ (if record?
+ (set! *register-map*
+ (set-machine-register-label *register-map*
+ target
+ immediate)))
+ result)))))))
+
+(define (get-immediate-aliases immediate)
+ (let loop ((entries
+ (cons (list 0 regnum:zero)
+ (register-map-labels *register-map* 'GENERAL))))
+ (cond ((null? entries)
+ '())
+ ((eqv? (caar entries) immediate)
+ (append (cdar entries) (loop (cdr entries))))
+ (else
+ (loop (cdr entries))))))
+
+(define (%load-immediate target immediate)
+ ; All simple cases are handled above this level.
+ #|
+ (let ((label (immediate->label immediate)))
+ (load-pc-relative target 'IMMEDIATE label))
+ |#
+ (warn "%load-immediate: generating 64-bit constant" (number->string immediate 16))
+ (with-values (lambda () (split-64-bits immediate))
+ (lambda (high low)
+ (let ((left-half (load-immediate target high false)))
+ (LAP ,@left-half
+ (SLL ,target (& 32) ,target)
+ ,@(add-immediate low target target))))))
+
+(define (add-immediate immediate source target)
+ (cond ((fits-in-16-bits-signed? immediate)
+ (LAP (LDA ,target (OFFSET ,immediate ,source))))
+ ((top-16-of-32-bits-only? immediate)
+ (LAP (LDAH ,target (OFFSET ,(->signed (quotient immediate #x10000) 16)
+ ,source))))
+ ((fits-in-32-bits-signed? immediate)
+ (LAP (LDA ,target (OFFSET ,(adjusted:low immediate) ,source))
+ (LDAH ,target (OFFSET ,(adjusted:high immediate) ,target))))
+ (else (with-values (lambda () (immediate->register immediate))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ (ADDQ ,source ,alias ,target)))))))
+\f
+;;;; Comparisons
+
+(define (compare-immediate condition immediate source)
+ ; Branch if immediate <condition> source
+ (let ((cc (invert-condition-noncommutative condition)))
+ ;; This machine does register <op> immediate; you can
+ ;; now think of cc in this way
+ (cond ((zero? immediate)
+ (branch-generator! cc
+ `(BEQ ,source) `(BLT ,source) `(BGT ,source)
+ `(BNE ,source) `(BGE ,source) `(BLE ,source))
+ (LAP))
+ ((fits-in-8-bits-unsigned? immediate)
+ (let ((temp (standard-temporary!)))
+ (branch-generator! condition
+ `(BNE ,temp) `(BNE ,temp) `(BEQ ,temp)
+ `(BEQ ,temp) `(BEQ ,temp) `(BNE ,temp))
+ (case condition
+ ((= <>) (LAP (CMPEQ ,source (& ,immediate) ,temp)))
+ ((< >=) (LAP (CMPLT ,source (& ,immediate) ,temp)))
+ ((> <=) (LAP (CMPLE ,source (& ,immediate) ,temp))))))
+ (else (with-values (lambda () (immediate->register immediate))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ ,@(compare condition alias source))))))))
+
+(define (compare condition r1 r2)
+ ; Branch if r1 <cc> r2
+ (if (= r1 r2)
+ (let ((branch
+ (lambda (label) (LAP (BR ,regnum:came-from (@PCR ,label)))))
+ (dont-branch
+ (lambda (label) label (LAP))))
+ (if (memq condition '(< > <>))
+ (set-current-branches! dont-branch branch)
+ (set-current-branches! branch dont-branch))
+ (LAP))
+ (let ((temp (standard-temporary!)))
+ (branch-generator! condition
+ `(BNE ,temp) `(BNE ,temp) `(BNE ,temp)
+ `(BEQ ,temp) `(BEQ ,temp) `(BEQ ,temp))
+ (case condition
+ ((= <>) (LAP (CMPEQ ,r1 ,r2 ,temp)))
+ ((< >=) (LAP (CMPLT ,r1 ,r2 ,temp)))
+ ((> <=) (LAP (CMPLT ,r2 ,r1 ,temp)))))))
+
+(define (branch-generator! cc = < > <> >= <=)
+ (let ((forward
+ (case cc
+ ((=) =) ((<) <) ((>) >)
+ ((<>) <>) ((>=) >=) ((<=) <=)))
+ (inverse
+ (case cc
+ ((=) <>) ((<) >=) ((>) <=)
+ ((<>) =) ((>=) <) ((<=) >))))
+ (set-current-branches!
+ (lambda (label)
+ (LAP (,@forward (@PCR ,label))))
+ (lambda (label)
+ (LAP (,@inverse (@PCR ,label)))))))
+
+(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->type source target)
+ ; Type extraction
+ (LAP (EXTBL ,source (& 7) ,target)))
+
+(define-integrable (object->datum source target)
+ ; Zero out the type field
+ (LAP (ZAP ,source (& 128) ,target)))
+
+(define-integrable (object->address source target)
+ (object->datum source target))
+
+(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 (new-temporary! . avoid)
+ (let loop ()
+ (let ((result (allocate-temporary-register! 'GENERAL)))
+ (if (memq result avoid)
+ (loop)
+ result))))
+
+(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))
+ regnum:zero)))
+ ((CONS-NON-POINTER)
+ (and (let ((type (rtl:cons-non-pointer-type expression)))
+ (and (rtl:machine-constant? type)
+ (zero? (rtl:machine-constant-value type))))
+ (let ((datum (rtl:cons-non-pointer-datum expression)))
+ (and (rtl:machine-constant? datum)
+ (zero? (rtl:machine-constant-value datum))))
+ regnum:zero))
+ ((MACHINE-CONSTANT)
+ (and (zero? (rtl:machine-constant-value expression))
+ regnum:zero))
+ (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-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 8-byte registers followed by 256
+ ;; 8-byte temporaries.
+ (+ (* 8 16) ; 16 machine independent, microcode
+ (* 8 8) ; 8 Alpha, compiled code interface
+ (* 8 (register-renumber register))))
+
+(define-integrable (float-register->fpr register)
+ ;; Float registers are represented by 32 through 63 in the RTL,
+ ;; corresponding to floating point registers 0 through 31 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 #x0018 ,regnum:regs-pointer)))
+
+(define-integrable reg:lexpr-primitive-arity
+ (INST-EA (OFFSET #x0038 ,regnum:regs-pointer)))
+
+(define-integrable reg:closure-limit
+ (INST-EA (OFFSET #x0050 ,regnum:regs-pointer)))
+
+(define-integrable reg:divq
+ (INST-EA (OFFSET #x00A0 ,regnum:regs-pointer)))
+
+(define-integrable reg:remq
+ (INST-EA (OFFSET #x00A8 ,regnum:regs-pointer)))
+
+(define (lap:make-label-statement label)
+ (LAP (LABEL ,label)))
+
+(define (lap:make-unconditional-branch label)
+ (LAP (BR ,regnum:came-from (@PCR ,label))))
+
+(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))
+
+(let-syntax ((define-codes
+ (macro (start . names)
+ (define (loop names offset)
+ (if (null? names)
+ '()
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'ASSEMBLY-HOOK:
+ (car names))
+ ,offset)
+ (loop (cdr names) (+ 16 offset)))))
+ `(BEGIN ,@(loop names start)))))
+ (define-codes #x0
+ long-jump
+ allocate-closure))
+
+(define (invoke-assembly-hook which-hook)
+ (LAP (LDA ,regnum:assembler-temp
+ (OFFSET ,which-hook ,regnum:closure-hook))
+ (JSR ,regnum:assembler-temp ,regnum:assembler-temp
+ (@PCO ,which-hook))))
+
+(define-integrable (link-to-interface code)
+ ;; Jump, with link in regnum:first-arg, to link_to_interface
+ (LAP (MOVEI ,regnum:interface-index (& ,code))
+ (JMP ,regnum:first-arg ,regnum:scheme-to-interface-jsr)))
+
+#| ;; Not actually needed ...
+(define-integrable (link-to-trampoline code)
+ ;; Jump, with link in 31, to trampoline_to_interface
+ (LAP (LDA ,regnum:assembler-temp (OFFSET -96xxx ,regnum:scheme-to-interface))
+ (MOVEI ,regnum:interface-index (& ,code))
+ (JMP ,regnum:linkage ,regnum:assembler-temp)))
+|#
+
+(define-integrable (invoke-interface code)
+ ;; Jump to scheme-to-interface
+ (LAP (MOVEI ,regnum:interface-index (& ,code))
+ (JMP ,regnum:linkage ,regnum:scheme-to-interface)))
+
+(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) '())
+ (if fourth (list regnum:fourth-arg) '()))))
+ (load-reg
+ (lambda (reg arg)
+ (if reg (load-machine-register! reg arg) (LAP)))))
+ (let ((load-regs
+ (LAP ,@(load-reg first regnum:first-arg)
+ ,@(load-reg second regnum:second-arg)
+ ,@(load-reg third regnum:third-arg)
+ ,@(load-reg fourth regnum:fourth-arg))))
+ (LAP ,@clear-regs
+ ,@load-regs
+ ,@(clear-map!)))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: lapopt.scm,v 1.1 1992/08/29 13:51:27 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; LAP Optimizer for Alpha.
+;;; Package: (compiler lap-optimizer)
+
+(declare (usual-integrations))
+
+(define (optimize-linear-lap instructions)
+ instructions)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: machin.scm,v 1.1 1992/08/29 13:51:27 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+;;; Machine Model for Alpha
+;;; Package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;;; Architecture Parameters
+
+(define use-pre/post-increment? false)
+(define-integrable endianness 'LITTLE)
+(define-integrable addressing-granularity 8)
+(define-integrable scheme-object-width 64)
+(define-integrable scheme-type-width 8) ; or 6
+
+(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 1)
+(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-gc&format-word
+ (quotient 32 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 execute-cache-size 2) ; Long words per UUO link slot
+(define-integrable closure-entry-size
+ ;; Long words in a single closure entry:
+ ;; Padding / Format and GC offset word
+ ;; SUBQ / BR or JMP
+ ;; absolute target address
+ 3)
+
+;; Given: the number of entry points in a closure, return: the
+;; distance in objects from the gc header word of the closure
+;; block to the location of the first free variable.
+
+(define (closure-object-first-offset nentries)
+ (case nentries
+ ((0)
+ ;; Vector header only
+ 1)
+ (else
+ ;; Manifest closure header, then entries.
+ (+ 1 (* closure-entry-size nentries)))))
+
+;; Given: the number of entry points in a closure, and a particular
+;; entry point number. Return: the distance from that entry point to
+;; the first variable slot in the closure (in words).
+
+(define (closure-first-offset nentries entry)
+ (if (zero? nentries)
+ 1 ; Strange boundary case
+ (- (* closure-entry-size (- nentries entry)) 1)))
+
+;; Bump from one entry point to another -- distance in BYTES
+
+(define (closure-entry-distance nentries entry entry*)
+ nentries ; ignored
+ (* (* closure-entry-size address-units-per-object)
+ (- entry* entry)))
+
+;; Bump to the canonical entry point. Since every closure entry point
+;; on the Alpha is aligned on an object boundary, there is no need to
+;; canonicalize.
+
+(define (closure-environment-adjustment nentries entry)
+ nentries entry ; ignored
+ 0)
+\f
+;;;; Machine Registers
+
+(define-integrable r0 0)
+(define-integrable r1 1)
+(define-integrable r2 2)
+(define-integrable r3 3)
+(define-integrable r4 4)
+(define-integrable r5 5)
+(define-integrable r6 6)
+(define-integrable r7 7)
+(define-integrable r8 8)
+(define-integrable r9 9)
+(define-integrable r10 10)
+(define-integrable r11 11)
+(define-integrable r12 12)
+(define-integrable r13 13)
+(define-integrable r14 14)
+(define-integrable r15 15)
+(define-integrable r16 16)
+(define-integrable r17 17)
+(define-integrable r18 18)
+(define-integrable r19 19)
+(define-integrable r20 20)
+(define-integrable r21 21)
+(define-integrable r22 22)
+(define-integrable r23 23)
+(define-integrable r24 24)
+(define-integrable r25 25)
+(define-integrable r26 26)
+(define-integrable r27 27)
+(define-integrable r28 28)
+(define-integrable r29 29)
+(define-integrable r30 30)
+(define-integrable r31 31)
+
+;; Floating point general registers -- the odd numbered ones are
+;; only used when transferring to/from the CPU
+(define-integrable f0 32)
+(define-integrable f1 33)
+(define-integrable f2 34)
+(define-integrable f3 35)
+(define-integrable f4 36)
+(define-integrable f5 37)
+(define-integrable f6 38)
+(define-integrable f7 39)
+(define-integrable f8 40)
+(define-integrable f9 41)
+(define-integrable f10 42)
+(define-integrable f11 43)
+(define-integrable f12 44)
+(define-integrable f13 45)
+(define-integrable f14 46)
+(define-integrable f15 47)
+(define-integrable f16 48)
+(define-integrable f17 49)
+(define-integrable f18 50)
+(define-integrable f19 51)
+(define-integrable f20 52)
+(define-integrable f21 53)
+(define-integrable f22 54)
+(define-integrable f23 55)
+(define-integrable f24 56)
+(define-integrable f25 57)
+(define-integrable f26 58)
+(define-integrable f27 59)
+(define-integrable f28 60)
+(define-integrable f29 61)
+(define-integrable f30 62)
+(define-integrable f31 63)
+
+(define-integrable number-of-machine-registers 64)
+(define-integrable number-of-temporary-registers 256)
+\f
+; Number .dis C Scheme
+; ====== ==== ======= ======
+; 0 v0 Return Value Return Value
+; 1 t0 caller saves <free, but utility index (not shifted)>
+; 2 t1 caller saves Stack-Pointer
+; 3 t2 caller saves MemTop
+; 4 t3 caller saves Free
+; 5 t4 caller saves Dynamic Link
+; 6 t5 caller saves <free>
+; 7 t6 caller saves <free>
+; 8 t7 caller saves <free>
+; 9 s0 callee saves Regs-Pointer
+; 10 s1 callee saves Scheme-To-Interface
+; 11 s2 callee saves Closure Hook (jump ind. for full addresse)
+; 12 s3 callee saves Scheme-To-Interface-JSR
+; 13 s4 callee saves Compiled-Entry-Type-Bits
+; 14 s5 callee saves Closure-Free
+; 15 fp? frame base <free>
+; 16 a0 argument 1 <free, but for utilities>
+; 17 a1 argument 2 <free, but for utilities>
+; 18 a2 argument 3 <free, but for utilities>
+; 19 a3 argument 4 <free, but for utilities>
+; 20 a4 argument 5 <free, but for utilities>
+; 21 a5 argument 6 <free>
+; 22 t8 caller saves <free>
+; 23 t9 caller saves <free>
+; 24 t10 caller saves <free>
+; 25 t11 caller saves <free>
+; 26 ra return address <free, but used for closure linkage>
+; 27 t12 proc. descript. <free>
+; 28 at? volatile scratch Assembler Temporary (tensioning)
+; 29 gp global pointer <free>
+; 30 sp stack pointer C Stack Pointer (do not use!)
+; 31 zero Z E R O Z E R O
+
+;;; Fixed-use registers due to architecture or OS calling conventions.
+;; Callee saves: r9-r15, r30 (stack pointer), f2-9 all others are caller saves
+(define-integrable regnum:C-return-value r0)
+(define-integrable regnum:C-frame-pointer r15)
+(define-integrable regnum:first-C-arg r16)
+(define-integrable regnum:second-C-arg r17)
+(define-integrable regnum:third-C-arg r18)
+(define-integrable regnum:fourth-C-arg r19)
+(define-integrable regnum:fifth-C-arg r20)
+(define-integrable regnum:sixth-C-arg r21)
+(define-integrable regnum:linkage r26)
+(define-integrable regnum:C-procedure-descriptor r27)
+(define-integrable regnum:volatile-scratch r28)
+(define-integrable regnum:C-global-pointer r29)
+(define-integrable regnum:C-stack-pointer r30)
+(define-integrable regnum:zero r31)
+\f
+(define-integrable regnum:fp-return-1 f0)
+(define-integrable regnum:fp-return-2 f1)
+(define-integrable regnum:first-fp-arg f16)
+(define-integrable regnum:second-fp-arg f17)
+(define-integrable regnum:third-fp-arg f18)
+(define-integrable regnum:fourth-fp-arg f19)
+(define-integrable regnum:fifth-fp-arg f20)
+(define-integrable regnum:sixth-fp-arg f21)
+(define-integrable regnum:fp-zero f31)
+
+;;; Fixed-use registers for Scheme compiled code.
+(define-integrable regnum:return-value regnum:C-return-value) ; 0
+(define-integrable regnum:interface-index r1) ; 1
+(define-integrable regnum:stack-pointer r2) ; 2
+(define-integrable regnum:memtop r3) ; 3
+(define-integrable regnum:free r4) ; 4
+(define-integrable regnum:dynamic-link r5) ; 5
+ ; (6, 7, 8)
+(define-integrable regnum:regs-pointer r9) ; 9
+(define-integrable regnum:scheme-to-interface r10) ; 10
+(define-integrable regnum:closure-hook r11) ; 11
+(define-integrable regnum:scheme-to-interface-jsr r12) ; 12
+(define-integrable regnum:compiled-entry-type-bits r13) ; 13
+(define-integrable regnum:closure-free r14) ; 14
+ ; (15, 16)
+;;;;;;; Note: regnum:first-C-arg is where the address for structure
+;;;;;;; return values is passed. Since all of the Scheme utilities
+;;;;;;; return structure values, we "hide" this register to correspond
+;;;;;;; to the C view of the argument number rather than the assembly
+;;;;;;; language view.
+(define-integrable regnum:first-arg regnum:second-C-arg) ; 17
+(define-integrable regnum:second-arg regnum:third-C-arg) ; 18
+(define-integrable regnum:third-arg regnum:fourth-C-arg) ; 19
+(define-integrable regnum:fourth-arg regnum:fifth-C-arg) ; 20
+ ; (21, 22, 23, 24, 25)
+(define-integrable regnum:closure-linkage regnum:linkage) ; 26
+ ; (27)
+(define-integrable regnum:assembler-temp regnum:volatile-scratch) ; 28
+(define-integrable regnum:came-from regnum:volatile-scratch) ; 28
+ ; (29)
+
+(define machine-register-value-class
+ (let ((special-registers
+ `((,regnum:return-value . ,value-class=object)
+ (,regnum:regs-pointer . ,value-class=unboxed)
+ (,regnum:scheme-to-interface . ,value-class=unboxed)
+ (,regnum:closure-hook . ,value-class=unboxed)
+ (,regnum:scheme-to-interface-jsr . ,value-class=unboxed)
+ (,regnum:dynamic-link . ,value-class=address)
+ (,regnum:free . ,value-class=address)
+ (,regnum:memtop . ,value-class=address)
+ (,regnum:assembler-temp . ,value-class=unboxed)
+ (,regnum:stack-pointer . ,value-class=address)
+ (,regnum:c-stack-pointer . ,value-class=unboxed))))
+ (lambda (register)
+ (let ((lookup (assv register special-registers)))
+ (cond
+ ((not (null? lookup)) (cdr lookup))
+ ((<= r0 register r31) value-class=word)
+ ((<= f0 register f31) 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. Cycles needed to generate value in specified
+ ;; register.
+ ;; Note: the 6 here is really two instructions (one to calculate the
+ ;; PC-relative address, the other to load from memory) that require
+ ;; 6 cycles worst case without cache miss.
+ (let ((if-integer
+ (lambda (value)
+ (if (or (zero? value)
+ (fits-in-16-bits-signed? value)
+ (top-16-of-32-bits-only? value))
+ 1
+ 6))))
+ (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))
+ 6)))
+ ((MACHINE-CONSTANT)
+ (if-integer (rtl:machine-constant-value expression)))
+ ((ENTRY:PROCEDURE
+ ENTRY:CONTINUATION
+ ASSIGNMENT-CACHE
+ VARIABLE-CACHE
+ OFFSET-ADDRESS)
+ 6)
+ ((CONS-NON-POINTER)
+ (and (rtl:machine-constant? (rtl:cons-non-pointer-type expression))
+ (rtl:machine-constant? (rtl:cons-non-pointer-datum expression))
+ (if-synthesized-constant
+ (rtl:machine-constant-value
+ (rtl:cons-non-pointer-type expression))
+ (rtl:machine-constant-value
+ (rtl:cons-non-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-*-
+
+$Id: make.scm,v 1.1 1992/08/29 13:51:28 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; Compiler: System Construction
+
+(declare (usual-integrations))
+
+((load "base/make") "Alpha")
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rgspcm.scm,v 1.1 1992/08/29 13:51:29 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; RTL Generation: Special primitive combinations. Alpha version.
+;;; Package: (compiler rtl-generator)
+
+(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-*-
+
+$Id: rules1.scm,v 1.1 1992/08/29 13:51:30 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; LAP Generation Rules: Data Transfers
+;; Package: (compiler lap-syntaxer)
+;; Syntax: lap-generator-syntax-table
+
+(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))))
+ (rules1-make-object target type datum))
+
+(define-rule statement
+ ;; tag the contents of a register
+ (ASSIGN (REGISTER (? target))
+ (CONS-NON-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (rules1-make-object target type datum))
+
+(define (rules1-make-object target type datum)
+ (let* ((type (standard-source! type))
+ (datum (standard-source! datum))
+ (target (standard-target! target)))
+ (LAP (SLL ,type (& ,scheme-datum-width) ,target)
+ (BIS ,datum ,target ,target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (deposit-type-address type source target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (deposit-type-datum type source 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))))
+ (standard-unary-conversion source target object->address))
+
+(define-rule statement
+ ;; add a distance (in longwords) to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (add-immediate (* address-units-per-object offset)
+ source target))))
+
+(define-rule statement
+ ;; add a distance (in bytes) to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (add-immediate offset source target))))
+\f
+;;;; Loading of Constants
+
+(define-rule statement
+ ;; load a machine constant
+ (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
+ (load-immediate (standard-target! target) source #T))
+
+(define-rule statement
+ ;; load a Scheme constant
+ (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
+ (load-constant (standard-target! target) source #T))
+
+(define-rule statement
+ ;; load the type part of a Scheme constant
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
+ (load-immediate (standard-target! target)
+ (make-non-pointer-literal 0 (object-type constant))
+ #T))
+
+(define-rule statement
+ ;; load the datum part of a Scheme constant
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
+ (QUALIFIER (non-pointer-object? constant))
+ (load-immediate (standard-target! target)
+ (make-non-pointer-literal 0 (careful-object-datum constant))
+ #T))
+
+(define-rule statement
+ ;; load a synthesized constant
+ (ASSIGN (REGISTER (? target))
+ (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (load-immediate (standard-target! target)
+ (make-non-pointer-literal type datum)
+ #T))
+\f
+(define-rule statement
+ ;; load the address of a variable reference cache
+ (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+ (load-pc-relative (standard-target! target)
+ 'CONSTANT
+ (free-reference-label name)))
+
+(define-rule statement
+ ;; load the address of an assignment cache
+ (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
+ (load-pc-relative (standard-target! target)
+ 'CONSTANT
+ (free-assignment-label name)))
+
+(define-rule statement
+ ;; load the address of a procedure's entry point
+ (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
+ (load-pc-relative-address (standard-target! target) 'CODE label))
+
+(define-rule statement
+ ;; load the address of a continuation
+ (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
+ (load-pc-relative-address (standard-target! target) 'CODE label))
+
+(define-rule statement
+ ;; load a procedure object
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:PROCEDURE (? label))))
+ (load-entry target type label))
+
+(define-rule statement
+ ;; load a return address object
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:CONTINUATION (? label))))
+ (load-entry target type label))
+
+(define (load-entry target type label)
+ (let ((temporary (standard-temporary!))
+ (target (standard-target! target)))
+ ;; Loading the address into a temporary makes it more useful,
+ ;; because it can be reused later.
+ (LAP ,@(load-pc-relative-address temporary 'CODE label)
+ ,@(deposit-type-address type temporary target))))
+\f
+;;;; Transfers from memory
+
+(define-rule statement
+ ;; read an object from memory
+ (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
+ (standard-unary-conversion address target
+ (lambda (address target)
+ (LAP (LDQ ,target
+ (OFFSET ,(* address-units-per-object offset) ,address))))))
+
+(define-rule statement
+ ;; Pop stack to register
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? stack)) 1))
+ (QUALIFIER (= stack regnum:stack-pointer))
+ (LAP (LDQ ,(standard-target! target) (OFFSET 0 ,regnum:stack-pointer))
+ (ADDQ ,regnum:stack-pointer (& ,address-units-per-object)
+ ,regnum:stack-pointer)))
+
+;;;; Transfers to memory
+
+(define-rule statement
+ ;; store an object in memory
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (? source register-expression))
+ (QUALIFIER (word-register? source))
+ (LAP (STQ ,(standard-source! source)
+ (OFFSET ,(* address-units-per-object offset)
+ ,(standard-source! address)))))
+
+(define-rule statement
+ ;; Push an object register on the heap
+ (ASSIGN (POST-INCREMENT (REGISTER (? Free)) 1)
+ (? source register-expression))
+ (QUALIFIER (and (= free regnum:free) (word-register? source)))
+ (LAP (STQ ,(standard-source! source) (OFFSET 0 ,regnum:free))
+ (ADDQ ,regnum:free (& ,address-units-per-object) ,regnum:free)))
+
+(define-rule statement
+ ;; Push an object register on the stack
+ (ASSIGN (PRE-INCREMENT (REGISTER (? stack)) -1)
+ (? source register-expression))
+ (QUALIFIER (and (= stack regnum:stack-pointer) (word-register? source)))
+ (LAP (STQ ,(standard-source! source)
+ (OFFSET ,(- address-units-per-object) ,regnum:stack-pointer))
+ (SUBQ ,regnum:stack-pointer (& ,address-units-per-object)
+ ,regnum:stack-pointer)))
+
+;; Cheaper, common patterns.
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (MACHINE-CONSTANT 0))
+ (LAP (STQ 31 (OFFSET ,(* address-units-per-object offset)
+ ,(standard-source! address)))))
+
+(define-rule statement
+ ; Push NIL (or whatever is represented by a machine 0) on heap
+ (ASSIGN (POST-INCREMENT (REGISTER (? free)) 1) (MACHINE-CONSTANT 0))
+ (QUALIFIER (= free regnum:free))
+ (LAP (STQ 31 (OFFSET 0 ,regnum:free))
+ (ADDQ ,regnum:free (& ,address-units-per-object) ,regnum:free)))
+
+(define-rule statement
+ ; Ditto, but on stack
+ (ASSIGN (PRE-INCREMENT (REGISTER (? stack)) -1) (MACHINE-CONSTANT 0))
+ (QUALIFIER (= stack regnum:stack-pointer))
+ (LAP (SW 31 (OFFSET ,(- address-units-per-object) ,regnum:stack-pointer))
+ (SUBQ ,regnum:stack-pointer (& ,address-units-per-object)
+ ,regnum:stack-pointer)))
+\f
+;;;; CHAR->ASCII/BYTE-OFFSET
+
+(define-rule statement
+ ;; convert char object to ASCII byte
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (REGISTER (? source))))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (LAP (AND ,source (& #xFF) ,target)))))
+
+(define-rule statement
+ ;; store null byte in memory
+ (ASSIGN (BYTE-OFFSET (REGISTER (? source)) (? offset))
+ (CHAR->ASCII (CONSTANT #\NUL)))
+ (modify-byte (standard-source! source) offset
+ (lambda (data-register offset-register)
+ data-register ; Ignored
+ offset-register ; Ignored
+ (LAP))))
+
+(define-rule statement
+ ;; load ASCII byte from memory
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET (REGISTER (? address)) (? offset)))
+ (load-byte address offset target))
+
+(define-rule statement
+ ;; store ASCII byte in memory. There may be a FIXNUM typecode.
+ (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (REGISTER (? source)))
+ (let ((source (standard-source! source))
+ (address (standard-source! address)))
+ (store-byte address offset source)))
+
+(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))))
+ (let ((source (standard-source! source))
+ (address (standard-source! address)))
+ (store-byte address offset source)))
+
+(define (modify-byte source offset update-byte)
+ (let* ((temp (standard-temporary!))
+ (byte-offset (modulo offset address-units-per-object)))
+ (if (and (zero? byte-offset) (fits-in-16-bits-signed? byte-offset))
+ (LAP (LDQ_U ,temp (OFFSET ,offset ,source))
+ (MSKBL ,temp ,source ,temp) ; Zero byte to modify
+ ,@(update-byte temp source)
+ (STQ_U ,temp (OFFSET ,offset ,source)))
+ (let ((address-temp (standard-temporary!)))
+ (LAP (LDA ,address-temp (OFFSET ,offset ,source))
+ (LDQ_U ,temp (OFFSET 0 ,address-temp))
+ (MSKBL ,temp ,address-temp ,temp) ; Zero byte to modify
+ ,@(update-byte temp address-temp)
+ (STQ_U ,temp (OFFSET 0 ,address-temp)))))))
+
+(define (store-byte address offset source)
+ (let ((temp (standard-temporary!)))
+ (modify-byte address offset
+ (lambda (data-register offset-register)
+ ;; data-register has the contents of memory with the desired
+ ;; byte set to zero; offset-register has the number of the
+ ;; machine register that holds the byte offset within word.
+ ;; INSBL moves the byte to be stored into the correct position
+ ;; BIS ORs the two together, completing the byte insert
+ (LAP (INSBL ,source ,offset-register ,temp)
+ (BIS ,data-register ,temp ,data-register))))))
+
+(define (load-byte address offset target)
+ (let* ((source (standard-source! address))
+ (target (standard-target! target))
+ (byte-offset (modulo offset address-units-per-object)))
+ (if (zero? byte-offset)
+ (LAP (LDQ_U ,target (OFFSET ,offset ,source))
+ (EXTBL ,target ,source ,target))
+ (let ((temp (standard-temporary!)))
+ (LAP (LDQ_U ,target (OFFSET ,offset ,source))
+ (LDA ,temp (OFFSET ,byte-offset ,source))
+ (EXTBL ,target ,temp ,target))))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules2.scm,v 1.1 1992/08/29 13:51:31 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; LAP Generation Rules: Predicates
+;; Package: (compiler lap-syntaxer)
+;; Syntax: lap-generator-syntax-table
+
+(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-pc-relative temp
+ 'CONSTANT (constant->label constant))
+ ,@(compare '= temp source))))))
+
+(define-rule predicate
+ ;; test for register EQ? to synthesized constant
+ (EQ-TEST (CONS-NON-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-NON-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-*-
+
+$Id: rules3.scm,v 1.1 1992/08/29 13:51:31 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; LAP Generation Rules: Invocations and Entries (Alpha)
+;; Package: (compiler lap-syntaxer)
+;; Syntax: lap-generator-syntax-table
+
+(declare (usual-integrations))
+\f
+;;;; Invocations
+
+(define-rule statement
+ (POP-RETURN)
+ (pop-return))
+
+(define (pop-return)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(clear-map!)
+ (LDQ ,temp (OFFSET 0 ,regnum:stack-pointer))
+ (ADDQ ,regnum:stack-pointer (& 8) ,regnum:stack-pointer)
+ (XOR ,temp ,regnum:compiled-entry-type-bits ,temp)
+ ; XOR instead of ,@(object->address temp temp)
+ (RET ,temp))))
+
+(define-rule statement
+ (INVOCATION:APPLY (? frame-size) (? continuation))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ ,@(load-immediate regnum:second-arg frame-size #F)
+ (LDQ ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
+ (ADDQ ,regnum:stack-pointer (& 8) ,regnum:stack-pointer)
+ ,@(invoke-interface code:compiler-apply)))
+
+(define-rule statement
+ (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+ frame-size continuation ;ignore
+ (LAP ,@(clear-map!)
+ (BR ,regnum:came-from (@PCR ,label))))
+
+(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
+ (let* ((clear-first-arg (clear-registers! regnum:first-arg))
+ (load-first-arg
+ (load-pc-relative-address regnum:first-arg 'CODE label)))
+ (LAP ,@clear-first-arg
+ ,@load-first-arg
+ ,@(clear-map!)
+ ,@(load-immediate regnum:second-arg number-pushed #F)
+ ,@(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 first-arg
+ (LAP ,@(clear-map!)
+ (LDQ ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
+ (ADDQ ,regnum:stack-pointer (& 8) ,regnum:stack-pointer)
+ ,@(object->address regnum:first-arg regnum:first-arg)
+ ,@(load-immediate regnum:second-arg number-pushed #F)
+ ,@(invoke-interface code:compiler-lexpr-apply)))
+\f
+(define-rule statement
+ (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ (BR ,regnum:came-from
+ (OFFSET 4 (@PCR ,(free-uuo-link-label name frame-size))))))
+
+(define-rule statement
+ (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ (BR ,regnum:came-from
+ (OFFSET 4 (@PCR ,(global-uuo-link-label name frame-size))))))
+
+(define-rule statement
+ (INVOCATION:CACHE-REFERENCE (? frame-size)
+ (? continuation)
+ (? extension register-expression))
+ continuation ;ignore
+ (let* ((clear-second-arg (clear-registers! regnum:second-arg))
+ (load-second-arg
+ (load-pc-relative-address regnum:second-arg 'CODE *block-label*)))
+ (LAP ,@clear-second-arg
+ ,@load-second-arg
+ ,@(load-interface-args! extension false false false)
+ ,@(load-immediate regnum:third-arg frame-size #F)
+ ,@(invoke-interface code:compiler-cache-reference-apply))))
+
+(define-rule statement
+ (INVOCATION:LOOKUP (? frame-size)
+ (? continuation)
+ (? environment register-expression)
+ (? name))
+ continuation ;ignore
+ (LAP ,@(load-interface-args! environment false false false)
+ ,@(load-constant regnum:second-arg name #F)
+ ,@(load-immediate regnum:third-arg frame-size #F)
+ ,@(invoke-interface code:compiler-lookup-apply)))
+\f
+(define-rule statement
+ (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
+ continuation ;ignore
+ (if (eq? primitive compiled-error-procedure)
+ (LAP ,@(clear-map!)
+ ,@(load-immediate regnum:first-arg frame-size #F)
+ ,@(invoke-interface code:compiler-error))
+ (let* ((clear-first-arg (clear-registers! regnum:first-arg))
+ (load-first-arg
+ (load-pc-relative regnum:first-arg
+ 'CONSTANT
+ (constant->label primitive))))
+ (LAP ,@clear-first-arg
+ ,@load-first-arg
+ ,@(clear-map!)
+ ,@(let ((arity (primitive-procedure-arity primitive)))
+ (cond ((not (negative? arity))
+ (invoke-interface code:compiler-primitive-apply))
+ ((= arity -1)
+ (LAP ,@(load-immediate regnum:assembler-temp
+ (-1+ frame-size)
+ #F)
+ (STQ ,regnum:assembler-temp
+ ,reg:lexpr-primitive-arity)
+ ,@(invoke-interface
+ code:compiler-primitive-lexpr-apply)))
+ (else
+ ;; Unknown primitive arity. Go through apply.
+ (LAP ,@(load-immediate regnum:second-arg frame-size #F)
+ ,@(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
+
+;;; (INVOCATION-PREFIX:MOVE-FRAME-UP frame-size address)
+
+;;; Move the topmost <frame-size> words of the stack downward so that
+;;; the bottommost of these words is at location <address>, and set
+;;; the stack pointer to the topmost of the moved words. That is,
+;;; discard the words between <address> and SP+<frame-size>, close the
+;;; resulting gap by shifting down the words from above the gap, and
+;;; adjust SP to point to the new topmost word.
+
+(define-rule statement
+ ;; Move up 0 words back to top of stack : a No-Op
+ (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER (? stack)))
+ (QUALIFIER (= stack regnum:stack-pointer))
+ (LAP))
+
+(define-rule statement
+ ;; Move <frame-size> words back to dynamic link marker
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? dlink)))
+ (QUALIFIER (= dlink regnum:dynamic-link))
+ (generate/move-frame-up frame-size
+ (lambda (reg) (LAP (COPY ,regnum:dynamic-link ,reg)))))
+
+(define-rule statement
+ ;; Move <frame-size> words back to SP+offset
+ (INVOCATION-PREFIX:MOVE-FRAME-UP
+ (? frame-size) (OFFSET-ADDRESS (REGISTER (? stack)) (? offset)))
+ (QUALIFIER (= stack regnum:stack-pointer))
+ (let ((how-far (* 8 (- 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 (LDQ ,temp (OFFSET 0 ,regnum:stack-pointer))
+ (ADDQ ,regnum:stack-pointer (& ,how-far)
+ ,regnum:stack-pointer)
+ (STQ ,temp (OFFSET 0 ,regnum:stack-pointer)))))
+ ((= frame-size 2)
+ (let ((temp1 (standard-temporary!))
+ (temp2 (standard-temporary!)))
+ (LAP (LDQ ,temp1 (OFFSET 0 ,regnum:stack-pointer))
+ (LDQ ,temp2 (OFFSET 8 ,regnum:stack-pointer))
+ (ADDQ ,regnum:stack-pointer (& ,how-far)
+ ,regnum:stack-pointer)
+ (STQ ,temp1 (OFFSET 0 ,regnum:stack-pointer))
+ (STQ ,temp2 (OFFSET 8 ,regnum:stack-pointer)))))
+ (else
+ (generate/move-frame-up frame-size
+ (lambda (reg)
+ (add-immediate (* 8 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)))
+ (QUALIFIER (not (= base 20)))
+ (generate/move-frame-up frame-size
+ (lambda (reg)
+ (add-immediate (* 8 offset) (standard-source! base) 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))))
+\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 (? dlink)))
+ (QUALIFIER (= dlink regnum:dynamic-link))
+ (if (and (zero? frame-size)
+ (= source regnum:stack-pointer))
+ (LAP)
+ (let ((env-reg (standard-move-to-temporary! source)))
+ (LAP (CMPULT ,env-reg ,regnum:dynamic-link ,regnum:assembler-temp)
+ (CMOVEQ ,regnum:assembler-temp ,regnum:dynamic-link ,env-reg)
+ ,@(generate/move-frame-up* frame-size env-reg)))))
+
+(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 (LDQ ,temp (OFFSET 0 ,regnum:stack-pointer))
+ (SUBQ ,destination (& 8) ,destination)
+ (STQ ,temp (OFFSET 0 ,destination)))))
+ (else
+ (let ((from (standard-temporary!))
+ (temp1 (standard-temporary!))
+ (temp2 (standard-temporary!)))
+ (LAP ,@(add-immediate (* 8 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 (LDQ ,temp1 (OFFSET -8 ,from))
+ (LDQ ,temp2 (OFFSET -16 ,from))
+ (LDQ ,temp3 (OFFSET -24 ,from))
+ (SUBQ ,from (& 24) ,from)
+ (STQ ,temp1 (OFFSET -8 ,destination))
+ (STQ ,temp2 (OFFSET -16 ,destination))
+ (STQ ,temp3 (OFFSET -24 ,destination))
+ (SUBQ ,destination (& 24) ,destination))))
+ (else
+ (LAP (LDQ ,temp1 (OFFSET -8 ,from))
+ (LDQ ,temp2 (OFFSET -16 ,from))
+ (SUBQ ,from (& 16) ,from)
+ (STQ ,temp1 (OFFSET -8 ,destination))
+ (STQ ,temp2 (OFFSET -16 ,destination))
+ (SUBQ ,destination (& 16) ,destination)
+ ,@(loop (- n 2))))))
+ (let ((label (generate-label)))
+ (LAP ,@(load-immediate temp2 frame-size #F)
+ (LABEL ,label)
+ (LDQ ,temp1 (OFFSET -8 ,from))
+ (SUBQ ,from (& 8) ,from)
+ (SUBQ ,temp2 (& 1) ,temp2)
+ (SUBQ ,destination (& 8) ,destination)
+ (STQ ,temp1 (OFFSET 0 ,destination))
+ (BNE ,temp2 (@PCR ,label)))))))))
+ (COPY ,destination ,regnum:stack-pointer)))
+\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 internal-continuation-code-word
+ (make-code-word #xff #xfc))
+
+(define (continuation-code-word label)
+ (frame-size->code-word
+ (if label
+ (rtl-continuation/next-continuation-offset (label->object label))
+ 0)
+ internal-continuation-code-word))
+
+(define (internal-procedure-code-word rtl-proc)
+ ;; represented as return addresses so the debugger will
+ ;; not barf when it sees them (on the stack if interrupted).
+ (frame-size->code-word
+ (rtl-procedure/next-continuation-offset rtl-proc)
+ internal-entry-code-word))
+
+(define (frame-size->code-word offset default)
+ (cond ((not offset)
+ default)
+ ((< offset #x2000)
+ ;; This uses up through (#xff #xdf).
+ (let ((qr (integer-divide offset #x80)))
+ (make-code-word (+ #x80 (integer-divide-remainder qr))
+ (+ #x80 (integer-divide-quotient qr)))))
+ (else
+ (error "Unable to encode continuation offset" offset))))
+\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.
+;;;
+;;; The only exception is the dynamic link register, handled
+;;; specially. Procedures that require a dynamic link use a different
+;;; interrupt handler that saves and restores the dynamic link
+;;; register.
+
+(define (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)
+ (COPY ,regnum:dynamic-link ,regnum:second-arg)
+ ,@(link-to-interface code:compiler-interrupt-dlink)
+ ,@(make-external-label code-word label)
+ ,@(interrupt-check gc-label))))
+
+(define (interrupt-check gc-label) ; Code sequence 2 in cmpint-alpha.h
+ (let ((Interrupt (generate-label))
+ (temp (standard-temporary!)))
+ (add-end-of-block-code! ; Make branch prediction work
+ (lambda ()
+ (LAP (LABEL ,Interrupt)
+ (BR ,regnum:came-from (@PCR ,gc-label)))))
+ (LAP (CMPLT ,regnum:free ,regnum:memtop ,temp)
+ (LDQ ,regnum:memtop ,reg:memtop)
+ (BEQ ,temp (@PCR ,Interrupt))))); forward, so predicted NOT taken
+
+(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-procedure-code-word rtl-proc)
+ 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-rule statement
+ (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+ entry ; Ignored
+ (if (zero? nentries)
+ (error "Closure header for closure with no entries!"
+ internal-label))
+ (let ((Interrupt (generate-label))
+ (merge (generate-label))
+ (interrupt-boolean (standard-temporary!)))
+ (add-end-of-block-code!
+ (lambda ()
+ (LAP
+ (LABEL ,internal-label) ; Code seq. 4 from cmpint-alpha.h
+ (CMPLT ,regnum:free ,regnum:memtop ,interrupt-boolean)
+ (LDQ ,regnum:memtop ,reg:memtop)
+ (BNE ,interrupt-boolean (@PCR ,merge))
+ (LABEL ,Interrupt) ; Code seq. 5 from cmpint-alpha.h
+ ,@(invoke-interface code:compiler-interrupt-closure))))
+ (let ((rtl-proc (label->object internal-label)))
+ (let ((label (rtl-procedure/external-label rtl-proc))
+ (reconstructed-closure (standard-temporary!)))
+ (LAP ; Code seq. 3 from cmpint-alpha.h
+ ,@(make-external-label (internal-procedure-code-word rtl-proc) label)
+ ; (SUBQ ,regnum:stack-pointer (& 8) ,regnum:stack-pointer)
+ (SUBQ ,regnum:linkage (& 8) ,reconstructed-closure)
+ (CMPLT ,regnum:free ,regnum:memtop ,interrupt-boolean)
+ (LDQ ,regnum:memtop ,reg:memtop)
+ (BIS ,regnum:compiled-entry-type-bits
+ ,reconstructed-closure ,reconstructed-closure)
+ (STQ ,reconstructed-closure (OFFSET 0 ,regnum:stack-pointer))
+ (BEQ ,interrupt-boolean (@PCR ,Interrupt))
+ (LABEL ,merge))))))
+
+(define (build-gc-offset-word offset code-word)
+ (let ((encoded-offset (quotient offset 2)))
+ (+ (* encoded-offset #x10000) code-word)))
+
+(define (allocate-closure rtl-target nentries n-free-vars)
+ (let ((target regnum:second-C-arg))
+ (require-register! regnum:first-C-arg)
+ (rtl-target:=machine-register! rtl-target target)
+ (let ((total-size
+ (+ 1 ; Closure header word
+ (* closure-entry-size nentries)
+ n-free-vars))
+ (limit (standard-temporary!))
+ (label (generate-label))
+ (forward-label (generate-label)))
+ (add-end-of-block-code!
+ (lambda ()
+ (LAP (LABEL ,forward-label)
+ (MOVEI ,regnum:first-C-arg (& ,total-size))
+ ; second-C-arg was set up because target==second-C-arg!
+ ,@(invoke-assembly-hook assembly-hook:allocate-closure)
+ (BR ,regnum:came-from (@PCR ,label)))))
+ (values
+ target
+ (LAP (LDA ,target (OFFSET 16 ,regnum:closure-free))
+ ;; Optional code (to reduce out-of-line calls):
+ (LDQ ,limit ,reg:closure-limit)
+ (LDA ,regnum:closure-free (OFFSET ,(* 8 total-size)
+ ,regnum:closure-free))
+ (CMPLT ,limit ,regnum:closure-free ,limit)
+ (BNE ,limit (@PCR ,forward-label))
+ ;; End of optional code -- convert BNE to BR to flush
+ (LABEL ,label)
+ ,@(with-values
+ (lambda ()
+ (immediate->register
+ (make-non-pointer-literal
+ (ucode-type manifest-closure) (- total-size 1))))
+ (lambda (prefix header)
+ (LAP ,@prefix
+ (STQ ,header (OFFSET -16 ,target)))))
+ ,@(with-values
+ (lambda ()
+ (immediate->register
+ (build-gc-offset-word 0 nentries)))
+ (lambda (prefix register)
+ (LAP ,@prefix
+ (STL ,register (OFFSET -8 ,target))))))))))
+
+(define (cons-closure target label min max size)
+ (with-values (lambda () (allocate-closure target 1 size))
+ (lambda (target prefix)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@prefix
+ ,@(with-values (lambda ()
+ (immediate->register
+ (build-gc-offset-word
+ 16 (make-procedure-code-word min max))))
+ (lambda (code reg)
+ (LAP ,@code
+ (STL ,reg (OFFSET -4 ,target)))))
+ ,@(load-pc-relative-address
+ temp 'CODE
+ (rtl-procedure/external-label (label->object label)))
+ (STQ ,temp (OFFSET 8 ,target)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+ (? min) (? max) (? size)))
+ (cons-closure target procedure-label min max size))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+ ;; entries is a vector of all the entry points
+ (case nentries
+ ((0)
+ (let ((dest (standard-target! target))
+ (temp (standard-temporary!)))
+ (LAP (COPY ,regnum:free ,dest)
+ ,@(load-immediate
+ temp
+ (make-non-pointer-literal (ucode-type manifest-vector) size)
+ #T)
+ (STQ ,temp (OFFSET 0 ,regnum:free))
+ (LDA ,regnum:free (OFFSET ,(* 8 (+ size 1))
+ ,regnum:free)))))
+ ((1)
+ (let ((entry (vector-ref entries 0)))
+ (cons-closure target (car entry) (cadr entry) (caddr entry) size)))
+ (else
+ (cons-multiclosure target nentries size (vector->list entries)))))
+
+(define (cons-multiclosure target nentries size entries)
+ (with-values (lambda () (allocate-closure target nentries size))
+ (lambda (target prefix)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@prefix
+ ,@(let loop ((offset 16)
+ (entries entries))
+ (if (null? entries)
+ (LAP)
+ (let* ((entry (car entries))
+ (label (car entry))
+ (min (cadr entry))
+ (max (caddr entry)))
+ (let* ((this-value
+ (load-immediate
+ temp
+ (build-gc-offset-word
+ offset (make-procedure-code-word min max)) #F))
+ (this-entry
+ (load-pc-relative-address
+ temp 'CODE
+ (rtl-procedure/external-label
+ (label->object label)))))
+ (LAP
+ ,@this-value
+ (STL ,temp (OFFSET ,(- offset 20) ,target))
+ ,@this-entry
+ (STQ ,temp (OFFSET ,(- offset 8) ,target))
+ ,@(loop (+ offset 24)
+ (cdr entries))))))))))))
+\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.
+ (in-assembler-environment (empty-register-map)
+ (list regnum:first-arg regnum:second-arg
+ regnum:third-arg regnum:fourth-arg)
+ (lambda ()
+ (let* (
+#| Bug in Alpha -- stq is dying at this location
+ (i1
+ (load-pc-relative-address regnum:fourth-arg
+ 'CONSTANT environment-label))
+|#
+ (i2 (load-pc-relative-address regnum:second-arg
+ 'CODE *block-label*))
+ (i3 (load-pc-relative-address regnum:third-arg
+ 'CONSTANT free-ref-label)))
+ (LAP
+ ;; Grab interp's env. and store in code block at environment-label
+#|
+ (LDQ ,regnum:first-arg ,reg:environment)
+ ,@i1
+ (STQ ,regnum:first-arg (OFFSET 0 ,regnum:fourth-arg))
+|#
+ ;; Now invoke the linker
+ ;; (arg1 is return address, supplied by interface)
+ ,@i2
+ ,@i3
+ (MOVEI ,regnum:fourth-arg (& ,n-sections))
+ ,@(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
+ (in-assembler-environment (empty-register-map)
+ (list regnum:first-arg regnum:second-arg
+ regnum:third-arg regnum:fourth-arg)
+ (lambda ()
+ (LAP ,@(load-pc-relative regnum:second-arg 'CODE code-block-label)
+ (LDQ ,regnum:first-arg ,reg:environment) ; first-arg is a temp here
+ ,@(object->address regnum:second-arg regnum:second-arg)
+ ,@(add-immediate environment-offset
+ regnum:second-arg
+ regnum:fourth-arg) ; fourth-arg is a temp here...
+ (STQ ,regnum:first-arg (OFFSET 0 ,regnum:fourth-arg))
+ ,@(add-immediate free-ref-offset regnum:second-arg regnum:third-arg)
+ (MOVEI ,regnum:fourth-arg (& ,n-sections))
+ ,@(link-to-interface code:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))))
+
+(define (in-assembler-environment map needed-registers thunk)
+ (fluid-let ((*register-map* map)
+ (*prefix-instructions* (LAP))
+ (*suffix-instructions* (LAP))
+ (*needed-registers* needed-registers))
+ (let ((instructions (thunk)))
+ (LAP ,@*prefix-instructions*
+ ,@instructions
+ ,@*suffix-instructions*))))
+\f
+(define (generate/constants-block constants references assignments uuo-links
+ global-links static-vars)
+ (let ((constant-info
+ (declare-constants 0 (transmogrifly uuo-links)
+ (declare-constants 1 references
+ (declare-constants 2 assignments
+ (declare-constants 3 (transmogrifly global-links)
+ (declare-constants false
+ (map (lambda (pair)
+ (cons false (cdr pair)))
+ static-vars)
+ (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)
+ (if (null? global-links) 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)
+ ; uuos == list of
+ ; (name (frame-size-1 . label-1) (frame-size-2 . label-2) ...)
+ ; produces ((frame-size-1 . label-1) (name . dummy-label)
+ ; (frame-size-2 . label-2) (name . dummy-label) ...)
+ (define (inner name assoc)
+ (if (null? assoc)
+ (transmogrifly (cdr uuos))
+ `((,(caar assoc) . ,(cdar assoc)) ; uuo-label
+ (,name . ,(allocate-constant-label))
+ ,@(inner name (cdr assoc)))))
+ (if (null? uuos)
+ '()
+ (inner (caar uuos) (cdar uuos))))
+\f
+;;; Local Variables: ***
+;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
+;;; End: ***
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules4.scm,v 1.1 1992/08/29 13:51:32 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; LAP Generation Rules: Interpreter Calls
+;; Package: (compiler lap-syntaxer)
+;; Syntax: lap-generator-syntax-table
+
+(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 regnum:third-arg name #F)
+ ,@(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 regnum:third-arg name #F #F)
+ ,@(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-*-
+
+$Id: rulfix.scm,v 1.1 1992/08/29 13:51:33 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; LAP Generation Rules: Fixnum Rules
+;; Package: (compiler lap-syntaxer)
+;; Syntax: lap-generator-syntax-table
+
+(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-immediate (standard-target! target) (* constant fixnum-1) #T))
+
+(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 (? value)))
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ #F))
+ (QUALIFIER (power-of-2 value))
+ (standard-unary-conversion source target (object-scaler value)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ (OBJECT->FIXNUM (CONSTANT (? value)))
+ #F))
+ (QUALIFIER (power-of-2 value))
+ (standard-unary-conversion source target (object-scaler value)))
+\f
+;; "Fixnum" in this context means an integer left shifted so that
+;; the sign bit is the leftmost bit of the word, i.e., the datum
+;; has been left shifted by scheme-type-width bits.
+
+(define (power-of-2 value)
+ (and (positive? value)
+ (let loop ((n value)
+ (exp 0))
+ (if (= n 1)
+ exp
+ (let ((division (integer-divide n 2)))
+ (and (zero? (integer-divide-remainder division))
+ (loop (integer-divide-quotient division)
+ (+ exp 1))))))))
+
+(define-integrable (object-scaler value)
+ (lambda (source target)
+ (scaled-object->fixnum (power-of-2 value) source target)))
+
+(define-integrable (datum->fixnum src tgt)
+ ; Shift left by scheme-type-width
+ (LAP (SLL ,src (& ,scheme-type-width) ,tgt)))
+
+(define-integrable (fixnum->datum src tgt)
+ (LAP (SRL ,src (& ,scheme-type-width) ,tgt)))
+
+(define-integrable (object->fixnum src tgt)
+ (datum->fixnum src tgt))
+
+(define-integrable (scaled-object->fixnum shift src tgt)
+ (LAP (SLL ,src (& ,(+ shift scheme-type-width)) ,tgt)))
+
+(define-integrable (address->fixnum src tgt)
+ ; Strip off type bits, just like object->fixnum
+ (datum->fixnum src tgt))
+
+(define-integrable (fixnum->object src tgt)
+ ; Move right by type code width and put on fixnum type code
+ (LAP ,@(fixnum->datum src tgt)
+ ,@(deposit-type-datum (ucode-type fixnum) tgt tgt)))
+
+(define (fixnum->address src tgt)
+ ; Move right by type code width; no address bits
+ (fixnum->datum src tgt))
+
+(define-integrable fixnum-1
+ (expt 2 scheme-type-width))
+
+(define-integrable -fixnum-1
+ (- fixnum-1))
+
+(define (no-overflow-branches!)
+ (set-current-branches!
+ (lambda (if-overflow)
+ if-overflow ; ignored
+ (LAP))
+ (lambda (if-no-overflow)
+ (LAP (BR ,regnum:came-from (@PCR ,if-no-overflow))))))
+
+(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
+;;;; 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))
+
+(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
+ (lambda (tgt src overflow?)
+ (if overflow?
+ (error "FIXNUM-NOT: overflow test requested"))
+ (LAP (EQV ,src (& ,(-1+ fixnum-1)) ,tgt))))
+
+(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (tgt src overflow?)
+ (fixnum-add-constant tgt src 1 overflow?)))
+
+(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (tgt src overflow?)
+ (fixnum-add-constant tgt src -1 overflow?)))
+
+(define (fixnum-add-constant tgt src constant overflow?)
+ (let ((constant (* fixnum-1 constant)))
+ (cond ((not overflow?)
+ (add-immediate constant src tgt))
+ ((zero? constant)
+ (no-overflow-branches!)
+ (LAP (COPY ,src ,tgt)))
+ (else
+ (with-values
+ (lambda ()
+ (cond
+ ((fits-in-16-bits-signed? constant)
+ (values (LAP)
+ (lambda (target)
+ (LAP (LDA ,target (OFFSET ,constant ,src))))))
+ ((top-16-of-32-bits-only? constant)
+ (values (LAP)
+ (lambda (target)
+ (LAP (LDAH ,target (OFFSET ,constant ,src))))))
+ (else
+ (with-values (lambda () (immediate->register constant))
+ (lambda (prefix alias)
+ (values prefix
+ (lambda (target)
+ (LAP (ADDQ ,src ,alias ,target)))))))))
+ (lambda (prefix add-code)
+ (let ((temp (new-temporary! src)))
+ (cond
+ ((positive? constant)
+ (begin
+ (set-current-branches!
+ (lambda (overflow-label)
+ (LAP (BLT ,temp (@PCR ,overflow-label))))
+ (lambda (no-overflow-label)
+ (LAP (BGE ,temp (@PCR ,no-overflow-label)))))
+ (LAP ,@prefix
+ ,@(add-code temp) ; Add, result to temp
+ (CMOVLT ,src ,regnum:zero ,temp)
+ ; sgn(src) != sgn(const) ->
+ ; no overflow
+ ,@(add-code tgt) ; Real result
+ ; (BLT ,temp (@PCR ,overflow-label))
+ )))
+ ((not (= src tgt))
+ (set-current-branches!
+ (lambda (overflow-label)
+ (LAP (BLT ,temp (@PCR ,overflow-label))))
+ (lambda (no-overflow-label)
+ (LAP (BGE ,temp (@PCR ,no-overflow-label)))))
+ (LAP ,@prefix
+ ,@(add-code tgt) ; Add, result to target
+ (XOR ,src ,tgt ,temp) ; Compare result and source sign
+ (CMOVGE ,src ,regnum:zero ,temp)
+ ; sgn(src) != sgn(const) ->
+ ; no overflow
+ ; (BLT ,temp (@PCR ,overflow-label))
+ ))
+ (else
+ (set-current-branches!
+ (lambda (overflow-label)
+ (LAP (BGE ,temp (@PCR ,overflow-label))))
+ (lambda (no-overflow-label)
+ (LAP (BLT ,temp (@PCR ,no-overflow-label)))))
+ (with-values
+ (lambda () (immediate->register -1))
+ (lambda (prefix2 reg:minus-1)
+ (LAP ,@prefix
+ ,@prefix2
+ ,@(add-code temp) ; Add, result to temp
+ (CMOVGE ,src ,reg:minus-1 ,temp)
+ ; sgn(src) != sgn(const) ->
+ ; no overflow
+ ,@(add-code tgt) ; Add, result to target
+ ; (BGE ,temp (@PCR ,overflow-label))
+ ))))))))))))
+\f
+(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-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (error "FIXNUM-AND: overflow test requested"))
+ (LAP (AND ,src1 ,src2 ,tgt))))
+
+(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (error "FIXNUM-OR: overflow test requested"))
+ (LAP (BIS ,src1 ,src2 ,tgt))))
+
+(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (error "FIXNUM-XOR: overflow test requested"))
+ (LAP (XOR ,src1 ,src2 ,tgt))))
+
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (do-overflow-addition tgt src1 src2)
+ (LAP (ADDQ ,src1 ,src2 ,tgt)))))
+
+(define (do-overflow-addition tgt src1 src2)
+ (let ((temp1 (new-temporary! src1 src2)))
+ (set-current-branches!
+ (lambda (overflow-label)
+ (LAP (BLT ,temp1 (@PCR ,overflow-label))))
+ (lambda (no-overflow-label)
+ (LAP (BGE ,temp1 (@PCR ,no-overflow-label)))))
+ (cond ((not (= src1 src2))
+ (let ((temp2 (new-temporary! src1 src2))
+ (src (if (= src1 tgt) src2 src1))) ; Non-clobbered source
+ (LAP (XOR ,src1 ,src2 ,temp2) ; Sign compare sources
+ (ADDQ ,src1 ,src2 ,tgt) ; Add them ...
+ (XOR ,src ,tgt ,temp1) ; Result sign OK?
+ (CMOVLT ,temp2 ,regnum:zero ,temp1)
+ ; Looks like sgn(result)=sgn(src)
+ ; if sgn(src1) != sgn(src2)
+ ; (BLT ,temp1 (@PCR ,overflow-label))
+ ; Sign differs -> overflow
+ )))
+ ((not (= src1 tgt))
+ (LAP (ADDQ ,src1 ,src2 ,tgt) ; Add
+ (XOR ,src1 ,tgt ,temp1))) ; Sign compare result
+ (else ; Don't test source signs
+ (LAP (ADDQ ,src1 ,src2 ,temp1) ; Interim sum
+ (XOR ,src1 ,temp1 ,temp1) ; Compare result & source signs
+ (ADDQ ,src1 ,src2 ,tgt) ; Final addition
+ ; (BLT ,temp1 (@PCR ,overflow-label))
+ ; Sign differs -> overflow
+ )))))
+\f
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (error "FIXNUM-ANDC: overflow test requested"))
+ (LAP (BIC ,src1 ,src2 ,tgt))))
+
+(define (with-different-source-and-target src tgt handler)
+ (if (not (= tgt src))
+ (handler src tgt)
+ (let ((temp (standard-temporary!)))
+ (LAP (COPY ,src ,temp)
+ ,@(handler tmp tgt)))))
+
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
+ (lambda (tgt value shift-amount overflow?)
+ (if overflow?
+ (error "FIXNUM-LSH: overflow test requested"))
+ (let* ((temp (standard-temporary!))
+ (temp-right (standard-temporary!)))
+ (with-different-source-and-target
+ value tgt
+ (lambda (value tgt)
+ (LAP (SRA ,shift-amount (& ,scheme-type-width) ,temp)
+ (SLL ,value ,temp ,tgt)
+ (SUBQ ,regnum:zero ,temp ,temp-right)
+ (SRL ,value ,temp-right ,temp-right)
+ (BIC ,temp-right (& ,(-1+ fixnum-1)) ,temp-right)
+ (CMOVLT ,shift-amount ,temp-right ,tgt)))))))
+
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (if (= src1 src2) ;probably won't ever happen.
+ (begin
+ (no-overflow-branches!)
+ (LAP (SUBQ ,src1 ,src1 ,tgt)))
+ (do-overflow-subtraction tgt src1 src2))
+ (LAP (SUBQ ,src1 ,src2 ,tgt)))))
+
+(define (do-overflow-subtraction tgt src1 src2)
+ ; Requires src1 != src2
+ (let ((temp1 (new-temporary! src1 src2))
+ (temp2 (new-temporary! src1 src2)))
+ (set-current-branches!
+ (lambda (overflow-label)
+ (LAP (BLT ,temp1 (@PCR ,overflow-label))))
+ (lambda (no-overflow-label)
+ (LAP (BGE ,temp1 (@PCR ,no-overflow-label)))))
+ (LAP (XOR ,src1 ,src2 ,temp2) ; Compare source signs
+ (SUBQ ,src1 ,src2 ,tgt) ; Subtract
+ ,@(if (= src1 tgt) ; Compare result and source sign
+ (LAP (EQV ,src2 ,tgt ,temp1))
+ (LAP (XOR ,src1 ,tgt ,temp1)))
+ (CMOVGE ,temp2 ,regnum:zero ,temp1) ; Same source signs ->
+ ; no overflow
+ ; (BLT ,temp1 (@PCR ,overflow-label))
+ )))
+
+(define (do-multiply tgt src1 src2 overflow?)
+ (let ((temp (new-temporary! src1 src2)))
+ (LAP (SRA ,src1 (& ,scheme-type-width) ,temp) ; unscale source 1
+ ,@(if overflow?
+ (let ((abs1 (new-temporary! src1 src2))
+ (abs2 (new-temporary! src1 src2))
+ (oflow? (new-temporary! src1 src2)))
+ (set-current-branches!
+ (lambda (overflow-label)
+ (LAP (BNE ,oflow? (@PCR ,overflow-label))))
+ (lambda (no-overflow-label)
+ (LAP (BEQ ,oflow? (@PCR ,no-overflow-label)))))
+ (LAP
+ (SUBQ ,regnum:zero ,temp ,abs1) ; ABS(unscaled(source1))
+ (CMOVGE ,temp ,temp ,abs1) ; ""
+ (SUBQ ,regnum:zero ,src2 ,abs2) ; ABS(source2)
+ (CMOVGE ,src2 ,src2 ,abs2) ; ""
+ ; high of abs(source2)*
+ (UMULH ,abs1 ,abs2 ,oflow?) ; abs(unscaled(source1))
+ (MULQ ,abs1 ,abs2 ,abs1) ; low of same
+ (CMOVLT ,abs1 ,src2 ,oflow?) ; If low end oflowed, make
+ ; sure that high end <> 0
+ ;; (BNE ,oflow? (@PCR overflow-label))
+ ; If high end <> 0 oflow
+ ))
+ (LAP))
+ (MULQ ,temp ,src2 ,tgt)))) ; Compute result
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args do-multiply)
+\f
+;;;; Division operations, unknown arguments
+
+#| ; This doesn't work because we get physical register numbers, not
+ ; rtl register numbers.
+
+(define (special-binary-operation operation hook end-code)
+ (lambda (target source1 source2 ovflw?)
+ (define (->machine-register source machine-reg)
+ (let ((code (load-machine-register! source machine-reg)))
+ ;; Prevent it from being allocated again.
+ (need-register! machine-reg)
+ code))
+ (require-register! r23)
+ (let* ((load-1 (->machine-register source1 r24))
+ (load-2 (->machine-register source2 r25))
+ (target (standard-target! target)))
+ (LAP ,@load-1
+ ,@load-2
+ (LDQ ,r23 ,hook)
+ (JSR ,r23 ,r23 (@PCO 0))
+ ,@(end-code ovflw? r24 target)))))
+|#
+
+(define (special-binary-operation operation hook end-code)
+ (lambda (target source1 source2 ovflw?)
+ (if (not (= target r23)) (require-register! r23))
+ (if (not (= target r24)) (require-register! r24))
+ (if (not (= target r25)) (require-register! r25))
+ (LAP
+ ,@(cond ((and (= source1 r25) (= source2 r24))
+ (LAP (COPY ,r24 ,r23)
+ (COPY ,r25 ,r24)
+ (COPY ,r23 ,r25)))
+ ((= source1 r25)
+ (LAP (COPY ,r25 ,r24)
+ ,@(copy source2 r25)))
+ (else
+ (LAP ,@(copy source2 r25)
+ ,@(copy source1 r24))))
+ (LDQ ,r23 ,hook)
+ (JSR ,r23 ,r23 (@PCO 0))
+ ,@(end-code ovflw? r24 target))))
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
+ (special-binary-operation
+ 'FIXNUM-QUOTIENT
+ reg:divq
+ (lambda (overflow? source target)
+ (if (not overflow?)
+ (LAP (SLL ,source (& ,scheme-type-width) ,target))
+ (with-different-source-and-target
+ source target
+ (lambda (source target)
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (BEQ ,temp (@PCR ,if-overflow))))
+ (lambda (if-no-overflow)
+ (LAP (BNE ,temp (@PCR ,if-no-overflow)))))
+ (LAP (SLL ,source (& ,scheme-type-width) ,target)
+ (SRA ,target (& ,scheme-type-width) ,temp)
+ (CMPEQ ,temp ,target ,temp)))))))))
+
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
+ (special-binary-operation 'FIXNUM-REMAINDER reg:remq
+ (lambda (overflow? src tgt)
+ (if overflow? (no-overflow-branches!))
+ (copy src tgt))))
+\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?)))
+ (QUALIFIER (case operation
+ ((FIXNUM-AND FIXNUM-OR FIXNUM-ANDC FIXNUM-XOR)
+ #F)
+ ((FIXNUM-REMAINDER)
+ (power-of-2 (abs constant)))
+ (else #T)))
+ (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?)))
+ (QUALIFIER (not (memq operation
+ '(FIXNUM-AND FIXNUM-OR FIXNUM-ANDC
+ FIXNUM-XOR FIXNUM-LSH FIXNUM-REMAINDER
+ FIXNUM-QUOTIENT))))
+ (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?)))))
+
+(define (fixnum-2-args/commutative? operator)
+ (memq operator '(PLUS-FIXNUM
+ MULTIPLY-FIXNUM
+ FIXNUM-AND
+ FIXNUM-OR
+ FIXNUM-XOR)))
+
+(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 (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))
+\f
+(define-arithmetic-method 'PLUS-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (fixnum-add-constant tgt src constant overflow?)))
+
+(define-arithmetic-method 'FIXNUM-LSH
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt source constant-shift-amount overflow?)
+ (if overflow?
+ (error "FIXNUM-LSH: overflow test requested"))
+ (guarantee-signed-fixnum constant-shift-amount)
+ (let ((nbits (abs constant-shift-amount)))
+ (cond ((zero? constant-shift-amount)
+ (copy source tgt))
+ ((>= nbits scheme-datum-width)
+ (LAP (COPY ,regnum:zero ,tgt)))
+ ((negative? constant-shift-amount)
+ (LAP (SRL ,source (& ,(fix:and nbits 63)) ,tgt)
+ (BIC ,tgt (& ,(-1+ fixnum-1)) ,tgt)))
+ (else
+ (LAP (SLL ,source (& ,(fix:and nbits 63)) ,tgt)))))))
+
+(define-arithmetic-method 'MINUS-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (fixnum-add-constant tgt src (- constant) overflow?)))
+
+;;;; Division operators with constant denominator
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant ovflw?)
+ (guarantee-signed-fixnum constant)
+ (case constant
+ ((0) (error "FIXNUM-QUOTIENT: Divide by zero"))
+ ((1) (if ovflw? (no-overflow-branches!)) (copy src tgt))
+ ((-1) (if (not ovflw?)
+ (LAP (SUBQ ,regnum:zero ,src ,tgt))
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (BNE ,temp (@PCR ,if-overflow))))
+ (lambda (if-no-overflow)
+ (LAP (BEQ ,temp (@PCR ,if-no-overflow)))))
+ (with-different-source-and-target
+ src tgt
+ (lambda (src tgt)
+ (LAP (SUBQ ,regnum:zero ,src ,tgt)
+ (CMPEQ ,src ,tgt ,temp)
+ (CMOVEQ ,src ,regnum:zero ,temp)))))))
+ (else
+ (if ovflw? (no-overflow-branches!))
+ (let* ((factor (abs constant))
+ (xpt (power-of-2 factor)))
+ (cond ((> factor signed-fixnum/upper-limit)
+ (copy regnum:zero tgt))
+ (xpt ; A power of 2
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(add-immediate (* (-1+ factor) fixnum-1) src temp)
+ (CMOVGE ,src ,src ,temp)
+ (SRA ,temp (& ,xpt) ,tgt)
+ (BIC ,tgt (& ,(-1+ fixnum-1)) ,tgt)
+ ,@(if (negative? constant)
+ (LAP (SUBQ ,regnum:zero ,tgt ,tgt))
+ (LAP)))))
+ (else
+ (with-different-source-and-target
+ src tgt
+ (lambda (src tgt)
+ (define max-word (expt 2 scheme-object-width))
+ (define (find-shift denom recvr)
+ (let loop ((shift 1)
+ (factor (ceiling (/ max-word denom))))
+ (let ((next
+ (ceiling
+ (/ (expt 2 (+ scheme-object-width shift))
+ denom))))
+ (if (>= next max-word)
+ (normalize (-1+ shift) factor recvr)
+ (loop (1+ shift) next)))))
+ (define (normalize shift factor recvr)
+ (do ((shift shift (-1+ shift))
+ (factor factor (quotient factor 2)))
+ ((or (zero? shift) (odd? factor))
+ (recvr shift factor))))
+ (let ((abs-val (standard-temporary!)))
+ (find-shift factor
+ (lambda (shift multiplier)
+ (with-values
+ (lambda () (immediate->register multiplier))
+ (lambda (prefix temp)
+ (LAP
+ ,@prefix
+ (SUBQ ,regnum:zero ,src ,abs-val)
+ (CMOVGE ,src ,src ,abs-val)
+ (SRL ,abs-val (& ,scheme-type-width) ,abs-val)
+ (UMULH ,abs-val ,temp ,abs-val)
+ ,@(if (= shift 0)
+ (LAP)
+ (LAP (SRL ,abs-val (& ,shift) ,abs-val)))
+ (SLL ,abs-val (& ,scheme-type-width) ,abs-val)
+ (SUBQ ,regnum:zero ,abs-val ,tgt)
+ ,@(if (positive? constant)
+ (LAP (CMOVGE ,src ,abs-val ,tgt))
+ (LAP
+ (CMOVLT ,src
+ ,abs-val
+ ,tgt))))))))))))))))))
+
+(define-arithmetic-method 'FIXNUM-REMAINDER
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant ovflw?)
+ (guarantee-signed-fixnum constant)
+ (if ovflw? (no-overflow-branches!))
+ (case constant
+ ((1 -1) (copy regnum:zero tgt))
+ (else
+ (let* ((keep-bits (+ scheme-type-width (power-of-2 (abs constant))))
+ (flush-bits (- scheme-object-width keep-bits))
+ (temp (standard-temporary!))
+ (sign (standard-temporary!)))
+ (LAP (SLL ,src (& ,flush-bits) ,temp)
+ (SRA ,src (& ,(- scheme-object-width 1)) ,sign)
+ (SRL ,temp (& ,flush-bits) ,temp)
+ (SLL ,sign (& ,keep-bits) ,sign)
+ (BIS ,sign ,temp ,tgt)
+ (CMOVEQ ,temp ,regnum:zero ,tgt)))))))
+
+;;;; Other operators with constant second argument
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (cond ((zero? constant)
+ (if overflow? (no-overflow-branches!))
+ (LAP (COPY ,regnum:zero ,tgt)))
+ ((= constant 1)
+ (if overflow? (no-overflow-branches!))
+ (LAP (COPY ,src ,tgt)))
+ ((power-of-2 constant)
+ => (lambda (power-of-two)
+ (if overflow?
+ (do-left-shift-overflow tgt src power-of-two)
+ (LAP (SLL ,src (& ,power-of-two) ,tgt)))))
+ (else
+ (with-values (lambda () (immediate->register (* constant fixnum-1)))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ ,@(do-multiply tgt src alias overflow?))))))))
+
+(define (do-left-shift-overflow tgt src power-of-two)
+ (let ((temp (new-temporary! src)))
+ (set-current-branches!
+ (lambda (overflow-label)
+ (LAP (BEQ ,temp (@PCR ,overflow-label))))
+ (lambda (no-overflow-label)
+ (LAP (BNE ,temp (@PCR ,no-overflow-label)))))
+ (with-different-source-and-target
+ src tgt
+ (lambda (src tgt)
+ (LAP (SLL ,src (& ,power-of-two) ,tgt)
+ (SRA ,tgt (& ,power-of-two) ,temp)
+ (CMPEQ ,src ,temp ,temp))))))
+
+(define-arithmetic-method 'MINUS-FIXNUM
+ fixnum-methods/2-args/constant*register
+ (lambda (tgt constant src overflow?)
+ (guarantee-signed-fixnum constant)
+ (with-values (lambda () (immediate->register (* constant fixnum-1)))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ ,@(if overflow?
+ (do-overflow-subtraction tgt alias src)
+ (LAP (SUBQ ,alias ,src ,tgt))))))))
+\f
+;;;; Predicates
+
+(define-rule predicate
+ (OVERFLOW-TEST)
+ ;; The RTL code generate guarantees that this instruction is always
+ ;; immediately preceded by a fixnum operation with the OVERFLOW?
+ ;; flag turned on. Furthermore, it also guarantees that there are
+ ;; no other fixnum operations with the OVERFLOW? flag set. So all
+ ;; the processing of overflow tests has been moved into the fixnum
+ ;; operations.
+ (LAP))
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ (compare (fixnum-pred-1->cc predicate)
+ (standard-source! source)
+ regnum:zero))
+
+(define (fixnum-pred-1->cc predicate)
+ (case predicate
+ ((ZERO-FIXNUM?) '=)
+ ((NEGATIVE-FIXNUM?) '<)
+ ((POSITIVE-FIXNUM?) '>)
+ (else (error "unknown fixnum predicate" predicate))))
+
+(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))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulflo.scm,v 1.1 1992/08/29 13:51:34 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; LAP Generation Rules: Flonum rules
+;; Package: (compiler lap-syntaxer)
+;; Syntax: lap-generator-syntax-table
+
+(declare (usual-integrations))
+\f
+(define fpr:zero (float-register->fpr regnum:fp-zero))
+
+(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-rule statement
+ ;; convert a floating-point number to a flonum object
+ (ASSIGN (REGISTER (? target))
+ (FLOAT->OBJECT (REGISTER (? source))))
+ (let* ((source (flonum-source! source))
+ (target (standard-target! target)))
+ (LAP
+ ,@(with-values
+ (lambda ()
+ (immediate->register
+ (make-non-pointer-literal (ucode-type manifest-nm-vector)
+ flonum-size)))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ (STQ ,alias (OFFSET 0 ,regnum:free)))))
+ ,@(deposit-type-address (ucode-type flonum) regnum:free target)
+ (STT ,source (OFFSET ,address-units-per-object ,regnum:free))
+ (ADDQ ,regnum:free (& ,(* address-units-per-object (+ 1 flonum-size)))
+ ,regnum:free))))
+
+(define-rule statement
+ ;; convert a flonum object to a floating-point number
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
+ (let* ((source (standard-source! source))
+ (temp (standard-temporary!))
+ (target (flonum-target! target)))
+ (LAP ,@(object->address source temp)
+ (LDT ,target (OFFSET ,address-units-per-object ,temp)))))
+\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))
+
+(define-arithmetic-method 'FLONUM-ABS flonum-methods/1-arg
+ (lambda (target source)
+ (LAP (CPYS ,fpr:zero ,source ,target))))
+
+(define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg
+ (lambda (target source)
+ ; The following line is suggested by the Alpha instruction manual
+ ; but it looks like it might generate a negative 0.0
+ ; (LAP (CPYSN ,source ,source ,target))
+ (LAP (SUBT ,fpr:zero ,source ,target))))
+
+(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 ,',source1 ,',source2 ,',target)))))))
+ (define-flonum-operation flonum-add ADDT)
+ (define-flonum-operation flonum-subtract SUBT)
+ (define-flonum-operation flonum-multiply MULT)
+ (define-flonum-operation flonum-divide DIVT))
+\f
+;;;; Flonum Predicates
+
+(define-rule predicate
+ (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ ;; No immediate zeros, easy to generate by subtracting from itself
+ (let ((source (flonum-source! source)))
+ (flonum-compare source
+ (case predicate
+ ((FLONUM-ZERO?) '(FBEQ FBNE))
+ ((FLONUM-NEGATIVE?) '(FBLT FBGE))
+ ((FLONUM-POSITIVE?) '(FBGT FBLE))
+ (else (error "unknown flonum predicate" predicate))))
+ (LAP)))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (let* ((source1 (flonum-source! source1))
+ (source2 (flonum-source! source2))
+ (temp (flonum-temporary!)))
+ (flonum-compare temp '(FBNE FBEQ))
+ (case predicate
+ ((FLONUM-EQUAL?) (LAP (CMPTEQ ,source1 ,source2 ,temp)))
+ ((FLONUM-LESS?) (LAP (CMPTLT ,source1 ,source2 ,temp)))
+ ((FLONUM-GREATER?) (LAP (CMPTLT ,source2 ,source1 ,temp)))
+ (else (error "unknown flonum predicate" predicate)))))
+
+(define (flonum-compare source opcodes)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (,(car opcodes) ,source (@PCR ,label))))
+ (lambda (label)
+ (LAP (,(cadr opcodes) ,source (@PCR ,label))))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulrew.scm,v 1.1 1992/08/29 13:51:35 jinx Exp $
+
+Copyright (c) 1992 Digital Equipment Corporation (D.E.C.)
+
+This software was developed at the Digital Equipment Corporation
+Cambridge Research Laboratory. 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 both the Digital Equipment Corporation Cambridge Research
+Lab (CRL) and the MIT Scheme project any improvements or extensions
+that they make, so that these may be included in future releases; and
+(b) to inform CRL and 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. D.E.C. has made no warrantee or representation that the operation
+of this software will be error-free, and D.E.C. 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 Digital Equipment Corporation
+nor of any adaptation thereof in any advertising, promotional, or
+sales literature without prior written consent from D.E.C. in each
+case.
+
+|#
+
+;;;; RTL Rewrite Rules
+;;; Package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Synthesized Data
+
+(define-rule rewriting
+ (CONS-NON-POINTER (REGISTER (? type register-known-value))
+ (REGISTER (? datum register-known-value)))
+ (QUALIFIER (and (rtl:machine-constant? type)
+ (rtl:machine-constant? datum)))
+ (rtl:make-cons-non-pointer type datum))
+
+(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 (REGISTER (? type register-known-value)) (? datum))
+ (QUALIFIER (rtl:machine-constant? type))
+ (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+ (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum))
+ (QUALIFIER (rtl:machine-constant? type))
+ (rtl:make-cons-non-pointer type datum))
+
+(define-rule rewriting
+ (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum))
+ (QUALIFIER
+ (and (rtl:object->type? type)
+ (rtl:constant? (rtl:object->type-expression type))))
+ (rtl:make-cons-non-pointer
+ (rtl:make-machine-constant
+ (object-type (rtl:object->type-expression datum)))
+ datum))
+
+(define-rule rewriting
+ (CONS-NON-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-non-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
+;;; 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
+ (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'ASSIGN target (rtl:make-machine-register regnum:zero)))
+
+(define-rule rewriting
+ (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-register regnum:zero)))
+
+(define-rule rewriting
+ (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-register regnum:zero)))
+
+(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-non-pointer? expression)
+ (and (let ((expression (rtl:cons-non-pointer-type expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))
+ (let ((expression (rtl:cons-non-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