--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compiler.cbf,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Script to incrementally compile the compiler (from .bins)
+
+(for-each compile-directory
+ '("back"
+ "base"
+ "fggen"
+ "fgopt"
+ "machines/C"
+ "rtlbase"
+ "rtlgen"
+ "rtlopt"))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compiler.pkg,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler Packaging
+\f
+(global-definitions "../runtime/runtim")
+
+(define-package (compiler)
+ (files "base/switch"
+ "base/hashtb"
+ "base/object" ;tagged object support
+ "base/enumer" ;enumerations
+ "base/sets" ;set abstraction
+ "base/mvalue" ;multiple-value support
+ "base/scode" ;SCode abstraction
+ "rtlbase/valclass" ;RTL: value classes
+ "machines/C/machin" ;machine dependent stuff
+ "machines/C/cutl" ;back-end odds and ends
+ "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-stack-checks?
+ 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/C/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"
+ ;; "base/asstop"
+ "machines/C/ctop")
+ (parent (compiler))
+ (export ()
+ cbf
+ cf
+ compile-bin-file
+ compile-procedure
+ compile-scode
+ compiler:reset!
+ ;; cross-compile-bin-file
+ ;; cross-compile-bin-file-end
+ )
+ (export (compiler)
+ canonicalize-label-name)
+ (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*
+ *disambiguator*
+ *external-labels*
+ *special-labels*
+ label->object
+ *invoke-interface*
+ *used-invoke-primitive*
+ *use-jump-execute-chache*
+ *use-pop-return*
+ *purification-root-object*)
+ (export (compiler debug)
+ *root-expression*
+ *rtl-procedures*
+ *rtl-graphs*)
+ (import (runtime compiler-info)
+ make-dbg-info-vector
+ split-inf-structure!)
+ (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/C/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/regmap" ;Hardware register allocator
+ "machines/C/cout" ;converts partial C code into one one big string
+ "machines/C/lapgen" ;code generation rules
+ "machines/C/rules1" ; " " "
+ "machines/C/rules2" ; " " "
+ "machines/C/rules3" ; " " "
+ "machines/C/rules4" ; " " "
+ "machines/C/rulfix" ; " " "
+ "machines/C/rulflo" ; " " "
+ "machines/C/rulrew" ;code rewriting rules
+ )
+ (parent (compiler))
+ (export ()
+ *C-procedure-name*)
+ (export (compiler)
+ available-machine-registers
+ fits-in-16-bits-signed?
+ fits-in-16-bits-unsigned?
+ top-16-bits-only?
+ lap-generator/match-rtl-instruction
+ lap:make-entry-point
+ lap:make-label-statement
+ lap:make-unconditional-branch
+ lap:syntax-instruction)
+ (export (compiler top-level)
+ current-register-list
+ fake-compiled-block-name
+ free-assignments
+ free-references
+ free-uuo-links
+ generate-lap
+ global-uuo-links
+ label-num
+ labels
+ make-fake-compiled-block
+ make-fake-compiled-procedure
+ make-special-labels
+ make-table
+ objects
+ permanent-register-list
+ stringify)
+ (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)
+ add-end-of-block-code!
+ bblock-linearize-lap
+ linearize-lap
+ set-current-branches!)
+ (export (compiler top-level)
+ *end-of-block-code*
+ linearize-lap))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compiler.sf,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Script to incrementally syntax the compiler
+\f
+;; Guarantee that the package modeller is loaded.
+(if (not (name->package '(CROSS-REFERENCE)))
+ (with-working-directory-pathname "../cref" (lambda () (load "make"))))
+
+;; Guarantee that the compiler's package structure exists.
+(if (not (name->package '(COMPILER)))
+ (begin
+ ;; If there is no existing package constructor, generate one.
+ (if (not (file-exists? "comp.bcon"))
+ (begin
+ ((access cref/generate-trivial-constructor
+ (->environment '(CROSS-REFERENCE)))
+ "comp")
+ (sf "comp.con" "comp.bcon")))
+ (load "comp.bcon")))
+
+;; Guarantee that the necessary syntactic transforms and optimizers
+;; are loaded.
+(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
+ (let ((sf-and-load
+ (lambda (files package)
+ (sf-conditionally files)
+ (for-each (lambda (file)
+ (load (string-append file ".bin") package))
+ files))))
+ (write-string "\n\n---- Loading compile-time files ----")
+ (sf-and-load '("base/switch" "base/hashtb") '(COMPILER))
+ (sf-and-load '("base/macros") '(COMPILER MACROS))
+ ((access initialize-package! (->environment '(COMPILER MACROS))))
+ (sf-and-load '("machines/C/decls") '(COMPILER DECLARATIONS))
+ (let ((environment (->environment '(COMPILER DECLARATIONS))))
+ (set! (access source-file-expression environment) "*.scm")
+ ((access initialize-package! environment)))
+ (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
+ (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
+ (sf-and-load '("rtlbase/valclass") '(COMPILER))
+ (fluid-let ((sf/default-syntax-table
+ (access compiler-syntax-table
+ (->environment '(COMPILER MACROS)))))
+ (sf-and-load '("machines/C/machin") '(COMPILER)))
+ (set! (access endianness (->environment '(COMPILER))) 'BIG)
+ (sf-and-load '("back/syntax")
+ '(COMPILER LAP-SYNTAXER))
+ (sf-and-load '("base/scode") '(COMPILER))
+ (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))))
+
+;; Resyntax any files that need it.
+((access syntax-files! (->environment '(COMPILER))))
+
+;; Rebuild the package constructors and cref.
+(cref/generate-constructors "comp")
+(sf "comp.con" "comp.bcon")
+(sf "comp.ldr" "comp.bldr")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: cout.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; C-output fake assembler and linker
+;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define *C-procedure-name* 'DEFAULT)
+
+(define (stringify suffix initial-label lap-code info-output-pathname)
+ (define (stringify-object x)
+ (cond ((string? x)
+ x)
+ ((symbol? x)
+ (%symbol->string x))
+ ((number? x)
+ (number->string x))
+ (else
+ (error "stringify: Unknown frob" x))))
+
+ (define (make-time-stamp)
+ (let ((time (get-decoded-time)))
+ (string-append
+ "_"
+ (number->string (decoded-time/second time)) "_"
+ (number->string (decoded-time/minute time)) "_"
+ (number->string (decoded-time/hour time)) "_"
+ (number->string (decoded-time/day time)) "_"
+ (number->string (decoded-time/month time)) "_"
+ (number->string (decoded-time/year time)))))
+
+ (define (->variable-declarations vars)
+ (if (null? vars)
+ (list "")
+ `("SCHEME_OBJECT\n\t "
+ ,(car vars)
+ ,@(append-map (lambda (var)
+ (list ",\n\t " var))
+ (cdr vars))
+ ";\n\t")))
+
+ (if *purification-root-object*
+ (define-object "PURIFICATION_ROOT"
+ (if (vector? (cdr *purification-root-object*))
+ *purification-root-object*
+ (cons (car *purification-root-object*)
+ (list->vector
+ (reverse (cdr *purification-root-object*)))))))
+
+ (define-object (special-label/debugging)
+ (let frob ((obj info-output-pathname))
+ (cond ((pathname? obj)
+ (->namestring obj))
+ ((pair? obj)
+ (cons (frob (car obj))
+ (frob (cdr obj))))
+ (else
+ obj))))
+
+ (define-object (special-label/environment) unspecific)
+
+ (define (choose-proc-name default midfix time-stamp)
+ (let ((path (and info-output-pathname
+ (if (pair? info-output-pathname)
+ (car info-output-pathname)
+ info-output-pathname))))
+
+ (cond ((not *C-procedure-name*)
+ (string-append default suffix time-stamp))
+ ((not (eq? *C-procedure-name* 'DEFAULT))
+ (string-append *C-procedure-name*
+ midfix
+ suffix))
+ ((not path)
+ (string-append default suffix time-stamp))
+ (else
+ (string-append (car (last-pair (pathname-directory path)))
+ "_"
+ (pathname-name path)
+ midfix
+ suffix)))))
+\f
+ (define (subroutine-information-1)
+ (cond ((eq? *invoke-interface* 'INFINITY)
+ (values (list "") (list "")))
+ ((< *invoke-interface* 5)
+ (values (list-tail (list
+ "\ninvoke_interface_0:\n\tsubtmp_1 = 0;\n"
+ "\ninvoke_interface_1:\n\tsubtmp_2 = 0;\n"
+ "\ninvoke_interface_2:\n\tsubtmp_3 = 0;\n"
+ "\ninvoke_interface_3:\n\tsubtmp_4 = 0;\n"
+ "\ninvoke_interface_4:\n\t"
+ "INVOKE_INTERFACE_CODE ();\n")
+ *invoke-interface*)
+ (list "int subtmp_code;\n\t"
+ "long subtmp_1,subtmp_2,subtmp_3,subtmp_4;\n\t")))
+ (else
+ (error "subroutine-information-1: Interface utilities take at most 4 arguments"
+ *invoke-interface*))))
+
+ (define (subroutine-information-2)
+ (if *used-invoke-primitive*
+ (values (list "\ninvoke_primitive:\n\t"
+ "INVOKE_PRIMITIVE_CODE ();")
+ (list "SCHEME_OBJECT primitive;\n\t"
+ "long primitive_nargs;\n\t"))
+ (values (list "") (list ""))))
+
+ (define (subroutine-information)
+ (with-values subroutine-information-1
+ (lambda (code-1 vars-1)
+ (with-values subroutine-information-2
+ (lambda (code-2 vars-2)
+ (values (append code-1 code-2)
+ (append vars-1 vars-2)))))))
+\f
+ (let ((n 1) ; First word is vector header
+ (initial-offset (label->offset initial-label)))
+ (with-values (lambda () (handle-labels n))
+ (lambda (n label-defines label-dispatch label-block-initialization
+ symbol-table)
+ (with-values (lambda () (handle-free-refs-and-sets n))
+ (lambda (n free-defines free-block-initialization free-symbols)
+ (with-values (lambda () (handle-objects n))
+ (lambda (n decl-code xtra-procs object-prefix object-defines temp-vars
+ object-block-initialization)
+ (let* ((time-stamp (make-time-stamp))
+ (code-name
+ (choose-proc-name "code" "" time-stamp))
+ (block-name
+ (choose-proc-name "data" "_data" time-stamp))
+ (decl-name (string-append "decl_" code-name)))
+ (with-values subroutine-information
+ (lambda (extra-code extra-variables)
+ (values
+ code-name
+ (cons* (cons (special-label/environment)
+ (-1+ n))
+ (cons (special-label/debugging)
+ (- n 2))
+ (append free-symbols symbol-table))
+ (list-of-strings->string
+ (map (lambda (x)
+ (list-of-strings->string x))
+ (list
+ (if (string-null? suffix)
+ (append
+ (file-prefix)
+ (list "DECLARE_COMPILED_CODE (\"" code-name
+ "\", " decl-name
+ ", " code-name ")\n\n"))
+ '())
+ xtra-procs
+
+ (if (string-null? suffix)
+ (append
+ (list "void\n"
+ "DEFUN_VOID (" decl-name ")\n{\n\t")
+ decl-code
+ (list "return;\n}\n\n"))
+ '())
+
+ label-defines
+ object-defines
+ free-defines
+ (list "\n")
+
+ (list "#ifndef BAND_ALREADY_BUILT\n")
+ (cons "static " (function-header block-name))
+ (list "SCHEME_OBJECT object = (ALLOCATE_VECTOR ("
+ (number->string (- n 1))
+ "L));\n\t"
+ "SCHEME_OBJECT * current_block = "
+ "(OBJECT_ADDRESS (object));\n\t")
+ (->variable-declarations temp-vars)
+ (list "\n\t")
+ object-prefix
+ label-block-initialization
+ free-block-initialization
+ object-block-initialization
+ (list "return (current_block);")
+ (function-trailer block-name)
+ (list "#endif /* BAND_ALREADY_BUILT */\n")
+ (list "\n")
+
+ (let ((header (function-header code-name)))
+ (if (string-null? suffix)
+ header
+ (cons "static " header)))
+ (function-decls)
+ (register-declarations)
+ extra-variables
+ (list
+ "goto perform_dispatch;\n\n"
+ (if *use-pop-return*
+ (string-append
+ "pop_return_repeat_dispatch:\n\n\t"
+ "POP_RETURN_REPEAT_DISPATCH();\n\n")
+ "")
+ "repeat_dispatch:\n\n\t"
+ "REPEAT_DISPATCH ();\n\n"
+ "perform_dispatch:\n\n\t"
+ "switch (LABEL_TAG (my_pc))\n\t"
+ "{\n\t case 0:\n"
+ "#ifndef BAND_ALREADY_BUILT\n\t\t"
+ "current_block = ("
+ block-name
+ " (my_pc));\n\t\t"
+ "return (¤t_block["
+ (stringify-object initial-offset)
+ "]);\n"
+ "#else /* BAND_ALREADY_BUILT */\n\t\t"
+ "error_band_already_built ();\n"
+ "#endif /* BAND_ALREADY_BUILT */\n")
+ label-dispatch
+ (list
+ "\n\t default:\n\t\t"
+ "ERROR_UNKNOWN_DISPATCH (my_pc);\n\t}\n\t")
+ (map stringify-object lap-code)
+ extra-code
+ (function-trailer code-name))))))))))))))))
+\f
+(define-integrable (list-of-strings->string strings)
+ (apply string-append strings))
+
+(define-integrable (%symbol->string sym)
+ (system-pair-car sym))
+
+(define (file-prefix)
+ (let ((time (get-decoded-time)))
+ (cons* "/* Emacs: this is properly parenthesized -*- C -*- code.\n"
+ " Thank God it was generated by a machine.\n"
+ " */\n\n"
+ "/* C code produced\n "
+ (decoded-time/date-string time)
+ " at "
+ (decoded-time/time-string time)
+ "\n by Liar version "
+ (let ((version false))
+ (for-each-system!
+ (lambda (system)
+ (if (substring? "Liar" (system/name system))
+ (set! version
+ (cons (system/version system)
+ (system/modification system))))
+ unspecific))
+ (if (not version)
+ "?.?"
+ (string-append (number->string (car version))
+ "."
+ (number->string (cdr version)))))
+ ".\n */\n\n"
+ includes)))
+
+(define includes
+ (list "#include \"liarc.h\"\n\n"))
+
+(define (function-header name)
+ (list "SCHEME_OBJECT *\n"
+ "DEFUN ("
+ name
+ ", (my_pc), SCHEME_OBJECT * my_pc)\n"
+ "{\n\tREGISTER int current_C_proc = (LABEL_PROCEDURE (my_pc));\n\t"))
+
+(define (function-decls)
+ (list
+ "REGISTER SCHEME_OBJECT * current_block;\n\t"
+ "SCHEME_OBJECT * dynamic_link;\n\t"
+ "DECLARE_VARIABLES ();\n\n\t"))
+
+(define (function-trailer name)
+ (list "\n} /* End of " name ". */\n"))
+
+(define (make-define-statement symbol val)
+ (string-append "#define " (if (symbol? symbol)
+ (symbol->string symbol)
+ symbol)
+ " "
+ (if (number? val)
+ (number->string val)
+ val)
+ "\n"))
+\f
+;;;; Object constructors
+
+(define new-variables)
+(define *subblocks*)
+(define num)
+
+(define (generate-variable-name)
+ (set! new-variables
+ (cons (string-append "tmpObj" (number->string num))
+ new-variables))
+ (set! num (1+ num))
+ (car new-variables))
+
+(define-integrable (table/find table value)
+ ;; assv ?
+ (assq value table))
+
+(define-integrable (guaranteed-fixnum? value)
+ (and (exact-integer? value)
+ (<= signed-fixnum/lower-limit value)
+ (< value signed-fixnum/upper-limit)))
+
+(define-integrable (guaranteed-long? value)
+ (and (exact-integer? value)
+ (<= guaranteed-long/lower-limit value)
+ (< value guaranteed-long/upper-limit)))
+
+(define trivial-objects
+ (list #f #t '() unspecific))
+
+(define (trivial? object)
+ (or (memq object trivial-objects)
+ (guaranteed-fixnum? object)))
+
+(define (name-if-complicated node)
+ (cond ((fake-compiled-block? node)
+ (let ((name (fake-block/name node)))
+ (set! new-variables (cons name new-variables))
+ name))
+ ((or (%record? node) (vector? node))
+ (generate-variable-name))
+ (else
+ false)))
+
+(define (build-table nodes)
+ (map cdr
+ (sort (sort/enumerate
+ (list-transform-positive
+ (let loop ((nodes nodes)
+ (table '()))
+ (if (null? nodes)
+ table
+ (loop (cdr nodes)
+ (insert-in-table (car nodes)
+ table))))
+ (lambda (pair)
+ (cdr pair))))
+ (lambda (entry1 entry2)
+ (let ((obj1 (cadr entry1))
+ (obj2 (cadr entry2)))
+ (if (not (fake-compiled-block? obj2))
+ (or (fake-compiled-block? obj1)
+ (< (car entry1) (car entry2)))
+ (and (fake-compiled-block? obj1)
+ (< (fake-block/index obj1)
+ (fake-block/index obj2)))))))))
+\f
+;; Hack to make sort a stable sort
+
+(define (sort/enumerate l)
+ (let loop ((l l) (n 0) (l* '()))
+ (if (null? l)
+ l*
+ (loop (cdr l)
+ (1+ n)
+ (cons (cons n (car l))
+ l*)))))
+
+(define (insert-in-table node table)
+ (cond ((trivial? node)
+ table)
+ ((table/find table node)
+ => (lambda (pair)
+ (if (not (cdr pair))
+ (set-cdr! pair (generate-variable-name)))
+ table))
+ (else
+ (let ((table
+ (cons (cons node (name-if-complicated node))
+ table)))
+
+ (define-integrable (do-vector-like node vlength vref)
+ (let loop ((table table)
+ (i (vlength node)))
+ (if (zero? i)
+ table
+ (let ((i-1 (-1+ i)))
+ (loop (insert-in-table (vref node i-1)
+ table)
+ i-1)))))
+
+ (cond ((pair? node)
+ (insert-in-table
+ (car node)
+ (insert-in-table (cdr node)
+ table)))
+ ((vector? node)
+ (do-vector-like node vector-length vector-ref))
+ ((or (fake-compiled-procedure? node)
+ (fake-compiled-block? node))
+ table)
+ ((%record? node)
+ (do-vector-like node %record-length %record-ref))
+ (else
+ ;; Atom
+ table))))))
+\f
+(define (top-level-constructor object&name)
+ ;; (values prefix suffix)
+ (let ((name (cdr object&name))
+ (object (car object&name)))
+ (cond ((pair? object)
+ (values '()
+ (list name " = (cons (SHARP_F, SHARP_F));\n\t")))
+ ((fake-compiled-block? object)
+ (set! *subblocks* (cons object *subblocks*))
+ (values (list name " = (initialize_subblock (\""
+ (fake-block/c-proc object)
+ "\"));\n\t")
+ '()))
+ ((fake-compiled-procedure? object)
+ (values '()
+ (list name " = "
+ (compiled-procedure-constructor
+ object)
+ ";\n\t")))
+ ((vector? object)
+ (values '()
+ (list name " = (ALLOCATE_VECTOR ("
+ (number->string (vector-length object))
+ "));\n\t")))
+ ((%record? object)
+ (values '()
+ (list name " = (ALLOCATE_RECORD ("
+ (number->string (%record-length object))
+ "));\n\t")))
+ (else
+ (values '()
+ (list name "\n\t = "
+ (->simple-C-object object)
+ ";\n\t"))))))
+
+(define (top-level-updator object&name table)
+ (let ((name (cdr object&name))
+ (object (car object&name)))
+
+ (define-integrable (do-vector-like object vlength vref vset-name)
+ (let loop ((i (vlength object))
+ (code '()))
+ (if (zero? i)
+ code
+ (let ((i-1 (- i 1)))
+ (loop i-1
+ `(,vset-name " (" ,name ", "
+ ,(number->string i-1) ", "
+ ,(constructor (vref object i-1)
+ table)
+ ");\n\t"
+ ,@code))))))
+
+ (cond ((pair? object)
+ (list "SET_PAIR_CAR (" name ", "
+ (constructor (car object) table) ");\n\t"
+ "SET_PAIR_CDR (" name ", "
+ (constructor (cdr object) table) ");\n\t"))
+ ((or (fake-compiled-block? object)
+ (fake-compiled-procedure? object))
+ '(""))
+ ((%record? object)
+ (do-vector-like object %record-length %record-ref "RECORD_SET"))
+ ((vector? object)
+ (do-vector-like object vector-length vector-ref "VECTOR_SET"))
+ (else
+ '("")))))
+\f
+(define (constructor object table)
+ (let process ((object object))
+ (cond ((table/find table object) => cdr)
+ ((pair? object)
+ (cond ((or (not (pair? (cdr object)))
+ (table/find table (cdr object)))
+ (string-append "(CONS (" (process (car object)) ", "
+ (process (cdr object)) "))"))
+ (else
+ (let loop ((npairs 0)
+ (object object)
+ (frobs '()))
+ (if (and (pair? object) (not (table/find table object)))
+ (loop (1+ npairs)
+ (cdr object)
+ (cons (car object) frobs))
+ ;; List is reversed to call rconsm
+ (string-append
+ "(RCONSM (" (number->string (1+ npairs))
+ (apply string-append
+ (map (lambda (frob)
+ (string-append ", "
+ (process frob)))
+ (cons object frobs)))
+ "))"))))))
+ ((fake-compiled-procedure? object)
+ (compiled-procedure-constructor object))
+ ((or (fake-compiled-block? object)
+ (vector? object)
+ (%record? object))
+ (error "constructor: Can't build directly"
+ object))
+ (else
+ (->simple-C-object object)))))
+
+(define (compiled-procedure-constructor object)
+ (string-append "(CC_BLOCK_TO_ENTRY ("
+ (fake-procedure/block-name object)
+ ", "
+ (number->string
+ (fake-procedure/label-index object))
+ "))"))
+\f
+(define (top-level-constructors table)
+ ;; (values prefix suffix)
+ ;; (append-map top-level-constructor table)
+ (let loop ((table (reverse table)) (prefix '()) (suffix '()))
+ (if (null? table)
+ (values prefix suffix)
+ (with-values (lambda () (top-level-constructor (car table)))
+ (lambda (prefix* suffix*)
+ (loop (cdr table)
+ (append prefix* prefix)
+ (append suffix* suffix)))))))
+
+(define (->constructors names objects)
+ ;; (values prefix-code suffix-code)
+ (let* ((table (build-table objects)))
+ (with-values (lambda () (top-level-constructors table))
+ (lambda (prefix suffix)
+ (values prefix
+ (append suffix
+ (append-map (lambda (object&name)
+ (top-level-updator object&name table))
+ table)
+ (append-map
+ (lambda (name object)
+ (list (string-append name "\n\t = "
+ (constructor object table)
+ ";\n\t")))
+ names
+ objects)))))))
+
+(define char-set:C-char-quoted
+ (char-set #\\ #\" #\'))
+
+(define char-set:C-string-quoted
+ (char-set #\\ #\" #\Tab #\VT #\BS #\Linefeed #\Return #\Page #\BEL))
+
+(define (C-quotify string)
+ (let ((index (string-find-next-char-in-set string char-set:C-string-quoted)))
+ (if (not index)
+ string
+ (let ((new (write-to-string string)))
+ (substring new 1 (-1+ (string-length new)))))))
+
+(define (C-quotify-char char)
+ (cond ((not (char-set-member? char-set:graphic char))
+ (cond ((char=? char #\NUL)
+ "'\\0'")
+ ((char-set-member? char-set:C-string-quoted char)
+ (string-append
+ "'"
+ (let ((s (write-to-string (make-string 1 char))))
+ (substring s 1 (-1+ (string-length s))))
+ "'"))
+ (else
+ (string-append
+ "'\\"
+ (let ((s (number->string (char-code char) 8)))
+ (if (< (string-length s) 3)
+ (string-append (make-string (- 3 (string-length s)) #\0)
+ s)
+ s))
+ "'"))))
+ ((char-set-member? char-set:C-char-quoted char)
+ (string-append "'\\" (make-string 1 char) "'"))
+ (else
+ (string-append "'" (make-string 1 char) "'"))))
+\f
+(define (->simple-C-object object)
+ (cond ((symbol? object)
+ (let ((name (symbol->string object)))
+ (string-append "(C_SYM_INTERN ("
+ (number->string (string-length name))
+ "L, \"" (C-quotify name) "\"))")))
+ ((string? object)
+ (string-append "(C_STRING_TO_SCHEME_STRING ("
+ (number->string (string-length object))
+ "L, \"" (C-quotify object) "\"))"))
+ ((number? object)
+ (let process ((number object))
+ (cond ((flo:flonum? number)
+ (string-append "(DOUBLE_TO_FLONUM ("
+ (number->string number) "))"))
+ ((guaranteed-long? number)
+ (string-append "(LONG_TO_INTEGER ("
+ (number->string number) "L))"))
+ ((exact-integer? number)
+ (let ((bignum-string
+ (number->string (if (negative? number)
+ (- number)
+ number)
+ 16)))
+ (string-append "(DIGIT_STRING_TO_INTEGER ("
+ (if (negative? number)
+ "true, "
+ "false, ")
+ (number->string
+ (string-length bignum-string))
+ "L, \"" bignum-string "\"))")))
+ ((and (exact? number) (rational? number))
+ (string-append "(MAKE_RATIO ("
+ (process (numerator number))
+ ", " (process (denominator number))
+ "))"))
+ ((and (complex? number) (not (real? number)))
+ (string-append "(MAKE_COMPLEX ("
+ (process (real-part number))
+ ", " (process (imag-part number))
+ "))"))
+ (else
+ (error "scheme->C-object: Unknown number" number)))))
+ ((eq? #f object)
+ "SHARP_F")
+ ((eq? #t object)
+ "SHARP_T")
+ ((null? object)
+ "NIL")
+ ((eq? object unspecific)
+ "UNSPECIFIC")
+ ((primitive-procedure? object)
+ (let ((arity (primitive-procedure-arity object)))
+ (if (< arity -1)
+ (error "scheme->C-object: Unknown arity primitive" object)
+ (string-append "(MAKE_PRIMITIVE_PROCEDURE (\""
+ (symbol->string
+ (primitive-procedure-name object))
+ "\", "
+ (number->string arity)
+ "))"))))
+ ((char? object)
+ (string-append "(MAKE_CHAR ("
+ (let ((bits (char-bits object)))
+ (if (zero? bits)
+ "0"
+ (string-append "0x" (number->string bits 16))))
+ ", ((unsigned) "
+ (C-quotify-char (make-char (char-code object) 0))
+ ")))"))
+ ((bit-string? object)
+ (let ((string (number->string (bit-string->unsigned-integer object)
+ 16)))
+ (string-append "(DIGIT_STRING_TO_BIT_STRING ("
+ (number->string (bit-string-length object)) "L, "
+ (number->string (string-length string)) "L, \""
+ (string-reverse string)
+ "\"))")))
+ ;; Note: The following are here because of the Scode interpreter
+ ;; and the runtime system.
+ ;; They are not necessary for ordinary code.
+ ((interpreter-return-address? object)
+ (string-append "(MAKE_OBJECT (TC_RETURN_CODE, 0x"
+ (number->string (object-datum object) 16)
+ "))"))
+ (else
+ (error "->simple-C-object: unrecognized-type"
+ object))))
+
+(define (string-reverse string)
+ (let* ((len (string-length string))
+ (res (make-string len)))
+ (do ((i (fix:- len 1) (fix:- i 1))
+ (j 0 (fix:+ j 1)))
+ ((fix:= j len) res)
+ (string-set! res i (string-ref string j)))))
+\f
+(define (handle-objects n)
+ ;; All the reverses produce the correct order in the output block.
+ ;; The incoming objects are reversed
+ ;; (environment, debugging label, purification root, etc.)
+
+ (fluid-let ((new-variables '())
+ (*subblocks* '())
+ (num 0))
+
+ (define (iter n table names defines objects)
+ (if (null? table)
+ (with-values
+ (lambda () (->constructors (reverse names)
+ (reverse objects)))
+ (lambda (prefix suffix)
+ (values n
+ (map fake-block->decl *subblocks*)
+ (append-map fake-block->c-code *subblocks*)
+ prefix
+ defines
+ new-variables
+ suffix)))
+ (let ((entry (car table)))
+ (iter (1+ n)
+ (cdr table)
+ (cons (string-append "current_block["
+ (entry-label entry) "]")
+ names)
+ (cons (make-define-statement (entry-label entry) n)
+ defines)
+ (cons (entry-value entry)
+ objects)))))
+
+ (iter n (reverse (table->list-of-entries objects)) '() '() '())))
+\f
+(define (handle-free-refs-and-sets start-offset)
+ ;; process free-uuo-links free-references free-assignments global-uuo-links
+ ;; return n defines initialization
+
+ (define (make-linkage-section-header start kind count)
+ (string-append "current_block[" (number->string start)
+ "L] = (MAKE_LINKER_HEADER (" kind
+ ", " (number->string count) "));\n\t"))
+
+ (define (insert-symbol label symbol)
+ (let ((name (symbol->string symbol)))
+ (string-append "current_block[" label
+ "] = (C_SYM_INTERN ("
+ (number->string (string-length name))
+ ", \"" name "\"));\n\t")))
+
+ (define (process-links start links kind)
+ (if (null? (cdr links))
+ (values start 0 '() '())
+ (let process ((count 0)
+ (links (cdr links))
+ (offset (+ start 1))
+ (defines '())
+ (inits '()))
+ (cond ((null? links)
+ (values offset
+ 1
+ (reverse defines)
+ (cons (make-linkage-section-header start kind count)
+ (reverse inits))))
+ ((null? (cdr (car links)))
+ (process count (cdr links) offset defines inits))
+ (else
+ (let ((entry (cadar links)))
+ (let ((name (caar links))
+ (arity (car entry))
+ (symbol (cdr entry)))
+ (process (1+ count)
+ (cons (cons (caar links) (cddar links))
+ (cdr links))
+ (+ offset 2)
+ (cons (make-define-statement symbol offset)
+ defines)
+ (cons (string-append
+ (insert-symbol symbol name)
+ "current_block["
+ symbol
+ " + 1] = ((SCHEME_OBJECT) ("
+ (number->string arity) "));\n\t")
+ inits)))))))))
+\f
+ (define (process-table start table kind)
+ (define (iter n table defines inits)
+ (if (null? table)
+ (values n
+ 1
+ (reverse defines)
+ (cons (make-linkage-section-header start kind
+ (- n (+ start 1)))
+ (reverse inits)))
+ (let ((symbol (entry-label (car table))))
+ (iter (1+ n)
+ (cdr table)
+ (cons (make-define-statement symbol n)
+ defines)
+ (cons (insert-symbol symbol (entry-value (car table)))
+ inits)))))
+
+ (if (null? table)
+ (values start 0 '() '())
+ (iter (1+ start) table '() '())))
+
+ (with-values
+ (lambda () (process-links start-offset free-uuo-links
+ "OPERATOR_LINKAGE_KIND"))
+ (lambda (offset uuos? uuodef uuoinit)
+ (with-values
+ (lambda ()
+ (process-table offset
+ (table->list-of-entries free-references)
+ "REFERENCE_LINKAGE_KIND"))
+ (lambda (offset refs? refdef refinit)
+ (with-values
+ (lambda ()
+ (process-table offset
+ (table->list-of-entries free-assignments)
+ "ASSIGNMENT_LINKAGE_KIND"))
+ (lambda (offset asss? assdef assinit)
+ (with-values
+ (lambda () (process-links offset global-uuo-links
+ "GLOBAL_OPERATOR_LINKAGE_KIND"))
+ (lambda (offset glob? globdef globinit)
+ (let ((free-references-sections (+ uuos? refs? asss? glob?)))
+ (values
+ offset
+ (append
+ uuodef refdef assdef globdef
+ (list
+ (make-define-statement
+ (special-label/free-references)
+ start-offset)
+ (make-define-statement
+ (special-label/number-of-sections)
+ free-references-sections)))
+ (append uuoinit refinit assinit globinit)
+ (list (cons (special-label/free-references)
+ start-offset)
+ (cons (special-label/number-of-sections)
+ free-references-sections)))))))))))))
+\f
+(define (handle-labels n)
+ (define (iter offset tagno labels label-defines
+ label-dispatch label-block-initialization
+ label-bindings)
+ (if (null? labels)
+ (values (- offset 1)
+ (reverse label-defines)
+ (reverse label-dispatch)
+ (cons (string-append
+ "current_block["
+ (number->string n)
+ "L] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, "
+ (number->string (- (- offset 1) (+ n 1)))
+ "));\n\t")
+ (reverse label-block-initialization))
+ label-bindings)
+ (let* ((label-data (car labels))
+ (a-symbol (or (symbol-1 label-data)
+ (symbol-2 label-data))))
+ (iter (+ offset 2)
+ (+ tagno 1)
+ (cdr labels)
+ (cons (string-append
+ (make-define-statement a-symbol offset)
+ (let ((other-symbol (or (symbol-2 label-data)
+ (symbol-1 label-data))))
+ (if (eq? other-symbol a-symbol)
+ ""
+ (make-define-statement other-symbol a-symbol)))
+ (if (dispatch-1 label-data)
+ (make-define-statement (dispatch-1 label-data)
+ tagno)
+ "")
+ (if (dispatch-2 label-data)
+ (make-define-statement (dispatch-2 label-data)
+ tagno)
+ ""))
+ label-defines)
+ (cons (string-append
+ "\n\t case "
+ (number->string tagno) ":\n\t\t"
+ "current_block = (my_pc - " a-symbol ");\n\t\t"
+ "goto "
+ (symbol->string (or (label-1 label-data)
+ (label-2 label-data)))
+ ";\n")
+ label-dispatch)
+ (cons (string-append
+ "WRITE_LABEL_DESCRIPTOR(¤t_block["
+ a-symbol "], 0x"
+ (number->string (code-word-sel label-data) 16)
+ ", " a-symbol ");\n\t"
+ "current_block [" a-symbol
+ "] = (MAKE_LABEL_WORD (current_C_proc, "
+ (number->string tagno)
+ "));\n\t")
+ label-block-initialization)
+ (append
+ (if (label-1 label-data)
+ (list (cons (label-1 label-data) offset))
+ '())
+ (if (label-2 label-data)
+ (list (cons (label-2 label-data) offset))
+ '())
+ label-bindings)))))
+
+ (iter (+ 2 n) 1 (reverse! labels) '() '() '() '()))
+\f
+(define-structure (fake-compiled-procedure
+ (constructor make-fake-compiled-procedure)
+ (conc-name fake-procedure/))
+ (block-name false read-only true)
+ (label-index false read-only true))
+
+(define-structure (fake-compiled-block
+ (constructor make-fake-compiled-block)
+ (conc-name fake-block/))
+ (name false read-only true)
+ (c-proc false read-only true)
+ (c-code false read-only true)
+ (index false read-only true))
+
+(define fake-compiled-block-name-prefix "ccBlock")
+
+(define (fake-compiled-block-name number)
+ (string-append fake-compiled-block-name-prefix
+ "_" (number->string (-1+ number))))
+
+(define (fake-block->decl block)
+ (string-append "declare_compiled_code (\""
+ (fake-block/c-proc block)
+ "\", NO_SUBBLOCKS, "
+ (fake-block/c-proc block)
+ ");\n\t"))
+
+(define (fake-block->c-code block)
+ (list (fake-block/c-code block)
+ "\f\n"))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: ctop.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; C-output fake assembler and linker
+;;; package: (compiler top-level)
+
+(declare (usual-integrations))
+\f
+;;;; Exports to the compiler
+
+(define c-code-tag (string->symbol "#[C-code]"))
+
+(define (compiler-file-output object pathname)
+ (let ((pair (vector-ref object 1)))
+ (call-with-output-file (pathname-new-type pathname "c")
+ (lambda (port)
+ (write-string (cdr pair) port)))
+ (fasdump (cons c-code-tag (car pair))
+ pathname)))
+
+(define (compiled-scode->procedure compiled-scode environment)
+ environment ; ignored
+ (error "compiled-scode->procedure: Not yet implemented"
+ compiled-scode))
+
+(define (cross-compile-bin-file input . more)
+ input more ; ignored
+ (error "cross-compile-bin-file: Meaningless"))
+
+(define (optimize-linear-lap lap-program)
+ lap-program)
+
+(define (recursive-compilation-results)
+ (sort *recursive-compilation-results*
+ (lambda (x y)
+ (< (vector-ref x 0)
+ (vector-ref y 0)))))
+
+;; Global variables for assembler and linker
+
+(define *recursive-compilation-results*)
+
+;; First set: phase/rtl-generation
+;; Last used: phase/link
+(define *block-label*)
+(define *disambiguator*)
+
+(define *start-label*)
+
+;; First set: phase/lap-generation
+;; Last used: phase/info-generation-2
+(define *external-labels*)
+(define *special-labels*)
+
+;; First set: phase/lap-generation
+;; Last used: phase/output-generation ???
+(define *invoke-interface*)
+(define *used-invoke-primitive*)
+(define *use-jump-execute-chache*)
+(define *use-pop-return*)
+(define *purification-root-object*)
+
+;; First set: phase/assemble
+;; Last used: phase/output-generation
+(define *C-proc-name*)
+(define *labels*)
+(define *code*)
+
+;; First set: phase/output-generation
+(define *result*)
+
+(define (assemble&link info-output-pathname)
+ (phase/assemble info-output-pathname)
+ (if info-output-pathname
+ (phase/info-generation-2 *labels* info-output-pathname))
+ (phase/output-generation)
+ *result*)
+
+(define (wrap-lap entry-label some-lap)
+ (set! *start-label* entry-label)
+ (LAP ,@(if *procedure-result?*
+ (LAP)
+ (lap:make-entry-point entry-label *block-label*))
+ ,@some-lap))
+\f
+(define (bind-assembler&linker-top-level-variables thunk)
+ (fluid-let ((*recursive-compilation-results* '()))
+ (thunk)))
+
+(define (bind-assembler&linker-variables thunk)
+ (fluid-let ((current-register-list)
+ (free-assignments)
+ (free-references)
+ (free-uuo-links)
+ (global-uuo-links)
+ (label-num)
+ (labels)
+ (objects)
+ (permanent-register-list)
+ (*block-label*)
+ (*disambiguator*)
+ (*start-label*)
+ (*external-labels*)
+ (*special-labels*)
+ (*invoke-interface*)
+ (*used-invoke-primitive*)
+ (*use-jump-execute-chache*)
+ (*use-pop-return*)
+ (*purification-root-object*)
+ (*end-of-block-code*)
+ (*C-proc-name*)
+ (*labels*)
+ (*code*))
+ (thunk)))
+
+(define (assembler&linker-reset!)
+ (set! *recursive-compilation-results* '())
+ (set! current-register-list)
+ (set! free-assignments)
+ (set! free-references)
+ (set! free-uuo-links)
+ (set! global-uuo-links)
+ (set! label-num)
+ (set! labels)
+ (set! objects)
+ (set! permanent-register-list)
+ (set! *block-label*)
+ (set! *disambiguator*)
+ (set! *start-label*)
+ (set! *external-labels*)
+ (set! *special-labels*)
+ (set! *invoke-interface*)
+ (set! *used-invoke-primitive*)
+ (set! *use-jump-execute-chache*)
+ (set! *use-pop-return*)
+ (set! *purification-root-object*)
+ (set! *end-of-block-code*)
+ (set! *C-proc-name*)
+ (set! *labels*)
+ (set! *code*)
+ unspecific)
+
+(define (initialize-back-end!)
+ (set! current-register-list '())
+ (set! free-assignments (make-table))
+ (set! free-references (make-table))
+ (set! free-uuo-links (list 'FOO))
+ (set! global-uuo-links (list 'BAR))
+ (set! label-num 0)
+ (set! labels '())
+ (set! objects (make-table))
+ (set! permanent-register-list '())
+ (set! *block-label* (generate-label))
+ (set! *disambiguator*
+ (if (zero? *recursive-compilation-number*)
+ ""
+ (string-append (number->string *recursive-compilation-number*)
+ "_")))
+ (set! *external-labels* '())
+ (set! *special-labels* (make-special-labels))
+ (set! *invoke-interface* 'INFINITY)
+ (set! *used-invoke-primitive* false)
+ (set! *use-jump-execute-chache* false)
+ (set! *use-pop-return* false)
+ (set! *purification-root-object* false)
+ (set! *end-of-block-code* (LAP))
+ unspecific)
+\f
+(define (phase/assemble pathname)
+ (compiler-phase
+ "Pseudo-Assembly" ; garbage collection
+ (lambda ()
+ (with-values
+ (lambda ()
+ (stringify
+ (if (eq? pathname 'RECURSIVE)
+ (string-append "_"
+ (number->string *recursive-compilation-number*))
+ "")
+ (last-reference *start-label*)
+ (last-reference *lap*)
+ (if (eq? pathname 'RECURSIVE)
+ (cons *info-output-filename*
+ *recursive-compilation-number*)
+ pathname)))
+ (lambda (proc-name labels code)
+ (set! *C-proc-name* proc-name)
+ (set! *labels* labels)
+ (set! *code* code)
+ unspecific)))))
+
+(define (phase/output-generation)
+ (if (not (null? *ic-procedure-headers*))
+ (error "phase/output-generation: Can't hack IC procedures"))
+
+ (set! *result*
+ (if *procedure-result?*
+ (let* ((linking-info *subprocedure-linking-info*)
+ (translate-label
+ (lambda (label)
+ (let ((place (assq label *labels*)))
+ (if (not place)
+ (error "translate-label: Not found" label)
+ (cdr place)))))
+ (translate-symbol
+ (lambda (index)
+ (translate-label (vector-ref linking-info index))))
+ (index *recursive-compilation-number*)
+ (name (fake-compiled-block-name index)))
+ (cons (make-fake-compiled-procedure
+ name
+ (translate-label *entry-label*))
+ (vector
+ (make-fake-compiled-block name
+ *C-proc-name*
+ *code*
+ index)
+ (translate-symbol 0)
+ (translate-symbol 1)
+ (translate-symbol 2))))
+ (cons *C-proc-name*
+ *code*)))
+
+ (if (not compiler:preserve-data-structures?)
+ (begin
+ (set! *subprocedure-linking-info*)
+ (set! *labels*)
+ (set! *block-label*)
+ (set! *entry-label*)
+ (set! *ic-procedure-headers*)
+ (set! *code*)
+ unspecific)))
+\f
+(define (phase/info-generation-2 labels pathname)
+ (info-generation-2 labels pathname))
+
+(define (info-generation-2 labels pathname)
+ (compiler-phase "Debugging Information Generation"
+ (lambda ()
+ (let ((info
+ (info-generation-phase-3
+ (last-reference *dbg-expression*)
+ (last-reference *dbg-procedures*)
+ (last-reference *dbg-continuations*)
+ labels
+ (last-reference *external-labels*))))
+ (cond ((eq? pathname 'KEEP) ; for dynamic execution
+ info)
+ ((eq? pathname 'RECURSIVE) ; recursive compilation
+ (set! *recursive-compilation-results*
+ (cons (vector *recursive-compilation-number*
+ info
+ false)
+ *recursive-compilation-results*))
+ unspecific)
+ (else
+ (compiler:dump-info-file
+ (let ((others (recursive-compilation-results)))
+ (if (null? others)
+ info
+ (list->vector
+ (cons info
+ (map (lambda (other) (vector-ref other 1))
+ others)))))
+ pathname)
+ *info-output-filename*))))))
+
+(define (compiler:dump-bci-file binf pathname)
+ (load-option 'COMPRESS)
+ (let ((bci-path (pathname-new-type pathname "bci")))
+ (split-inf-structure! binf false)
+ (call-with-temporary-filename
+ (lambda (bif-name)
+ (fasdump binf bif-name true)
+ (compress bif-name bci-path)))
+ (announce-info-files bci-path)))
+
+(define (announce-info-files . files)
+ (if compiler:noisy?
+ (let ((port (nearest-cmdl/port)))
+ (let loop ((files files))
+ (if (null? files)
+ unspecific
+ (begin
+ (fresh-line port)
+ (write-string ";")
+ (write (->namestring (car files)))
+ (write-string " dumped ")
+ (loop (cdr files))))))))
+
+(define compiler:dump-info-file compiler:dump-bci-file)
+\f
+;; This defintion exported to compiler to handle losing C name restrictions
+
+(define (canonicalize-label-name prefix)
+ (if (string-null? prefix)
+ "empty_string"
+ (let* ((str (if (char-alphabetic? (string-ref prefix 0))
+ (string-copy prefix)
+ (string-append "Z_" prefix)))
+ (len (string-length str)))
+ (do ((i 0 (1+ i)))
+ ((>= i len) str)
+ (let ((char (string-ref str i)))
+ (if (not (char-alphanumeric? char))
+ (string-set! str i
+ (case char
+ ((#\?) #\P)
+ ((#\!) #\B)
+ (else #\_)))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: cutl.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; C back-end utilities
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+(define (->back-end-number x)
+ (if (number? x)
+ (number->string x)
+ x))
+
+(define (back-end:= x y)
+ (cond ((and (number? x) (number? y))
+ (= x y))
+ (else
+ (equal? x y))))
+
+(define (back-end:+ x y)
+ (cond ((and (number? x) (number? y))
+ (+ x y))
+ ((and (number? y) (= y 0))
+ x)
+ ((and (number? x) (= x 0))
+ y)
+ (else
+ (string-append "("
+ (->back-end-number x)
+ " + "
+ (->back-end-number y)
+ ")"))))
+
+(define (back-end:- x y)
+ (cond ((and (number? x) (number? y))
+ (- x y))
+ ((and (number? y) (= y 0))
+ x)
+ ((equal? x y)
+ 0)
+ (else
+ (string-append "("
+ (->back-end-number x)
+ " - "
+ (->back-end-number y)
+ ")"))))
+
+(define (back-end:* x y)
+ (cond ((and (number? x) (number? y))
+ (* x y))
+ ((and (number? y) (= y 1))
+ x)
+ ((and (number? y) (= y 0))
+ 0)
+ ((and (number? x) (= x 1))
+ y)
+ ((and (number? x) (= x 0))
+ 0)
+ (else
+ (string-append "("
+ (->back-end-number x)
+ " * "
+ (->back-end-number y)
+ ")"))))
+
+(define (back-end:quotient x y)
+ (cond ((and (number? x) (number? y))
+ (quotient x y))
+ ((and (number? y) (= y 1))
+ x)
+ ((and (number? x) (= x 0))
+ 0)
+ ((equal? x y)
+ 1)
+ (else
+ (string-append "("
+ (->back-end-number x)
+ " / "
+ (->back-end-number y)
+ ")"))))
+
+(define (back-end:expt x y)
+ (cond ((and (number? x) (number? y))
+ (expt x y))
+ ((and (number? x)
+ (or (= x 0) (= x 1)))
+ x)
+ ((and (number? y) (= y 0))
+ 1)
+ ((and (number? y) (= y 1))
+ x)
+ ((and (number? x) (= x 2))
+ (string-append "(1 << "
+ (->back-end-number y)
+ ")"))
+ (else
+ (error "back-end:expt: Cannot exponentiate"
+ x y))))
+
+;; This is a lie, but it is used only in places where false is the
+;; correct default.
+
+(define (back-end:< x y)
+ (and (number? x)
+ (number? y)
+ (< x y)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: decls.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler File Dependencies
+;;; 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)
+ unspecific)
+
+(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/C"))))
+ (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))
+ unspecific)
+
+(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"
+ "toplev" ; "asstop" "crstop"
+ "blocks" "cfg1" "cfg2" "cfg3" "constr"
+ "contin" "ctypes" "debug" "enumer"
+ "infnew" "lvalue" "object" "pmerly" "proced"
+ "refctx" "rvalue" "scode" "sets" "subprb"
+ "switch" "utils")
+ (filename/append "back"
+ "insseq" "lapgn1" "lapgn2" "linear" "regmap")
+ (filename/append "machines/C"
+ "cout" "ctop" "machin" "rulrew" "rgspcm")
+ (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/C"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo" "cout")
+ lap-generator-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"))
+ (C-base
+ (filename/append "machines/C" "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/C" "machin"))
+ (lapgen-base
+ (append (filename/append "back" "linear" "regmap")
+ (filename/append "machines/C" "lapgen")))
+ (lapgen-body
+ (append
+ (filename/append "back" "lapgn1" "lapgn2")
+ (filename/append "machines/C"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo" "cout"
+ ))))
+
+ (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/C" "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/C"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlcfg" "base"
+ "cfg1" "cfg2" "cfg3")
+ (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
+ (define-integration-dependencies "rtlbase" "rtlcon" "machines/C"
+ "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/C"
+ "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/C"
+ "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 C-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 C-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/C" "rulrew"))
+ (append C-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
+ (filename/append "back" "linear"))))
+ (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)
+
+ (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" "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"))
+
+ (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/C"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo" "cout"
+ )
+ (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: lapgen.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rules for C. Shared utilities.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Compiler error reporting
+
+(define (comp-internal-error message location . irritants)
+ (apply error (cons (string-append "Internal inconsistency in "
+ (if (symbol? location)
+ (symbol->string location)
+ location)
+ ": "
+ message)
+ irritants)))
+
+;;;; Register-Allocator Interface
+
+(define (type->name type)
+ (case type
+ ((SCHEME_OBJECT)
+ "SCHEME_OBJECT")
+ ((SCHEME_OBJECT*)
+ "SCHEME_OBJECT *")
+ ((LONG)
+ "long")
+ ((CHAR*)
+ "char *")
+ ((ULONG)
+ "unsigned long")
+ ((DOUBLE)
+ "double")
+ (else
+ (comp-internal-error "Unknown type" 'TYPE->NAME type))))
+
+(define (reg*type->name reg type)
+ (case type
+ ((SCHEME_OBJECT)
+ (string-append "Obj" (number->string reg)))
+ ((SCHEME_OBJECT*)
+ (string-append "pObj" (number->string reg)))
+ ((LONG)
+ (string-append "Lng" (number->string reg)))
+ ((CHAR*)
+ (string-append "pChr" (number->string reg)))
+ ((ULONG)
+ (string-append "uLng" (number->string reg)))
+ ((DOUBLE)
+ (string-append "Dbl" (number->string reg)))
+ (else
+ (comp-internal-error "Unknown type" 'REG*TYPE->NAME type))))
+
+(define (machine-register-name reg)
+ (cond ((eq? reg regnum:stack-pointer)
+ "stack_pointer")
+ ((eq? reg regnum:free)
+ "free_pointer")
+ ((eq? reg regnum:regs)
+ "register_block")
+ ((eq? reg regnum:dynamic-link)
+ "dynamic_link")
+ ((eq? reg regnum:value)
+ "value_reg")
+ (else
+ (comp-internal-error "Unknown machine register"
+ 'MACHINE-REGISTER-NAME reg))))
+\f
+(define (machine-register-type reg)
+ (cond ((eq? reg regnum:value)
+ "SCHEME_OBJECT")
+ #|
+ ((eq? reg regnum:stack-pointer)
+ "SCHEME_OBJECT *")
+ ((eq? reg regnum:free)
+ "SCHEME_OBJECT *")
+ ((eq? reg regnum:regs)
+ "SCHEME_OBJECT *")
+ ((eq? reg regnum:dynamic-link)
+ "SCHEME_OBJECT *")
+ (else
+ (comp-internal-error "Unknown machine register"
+ 'MACHINE-REGISTER-TYPE reg))
+ |#
+ (else
+ "SCHEME_OBJECT *")))
+
+(define (machine-register-type-symbol reg)
+ (cond ((eq? reg regnum:value)
+ 'SCHEME_OBJECT)
+ #|
+ ((eq? reg regnum:stack-pointer)
+ 'SCHEME_OBJECT*)
+ ((eq? reg regnum:free)
+ 'SCHEME_OBJECT*)
+ ((eq? reg regnum:regs)
+ 'SCHEME_OBJECT*)
+ ((eq? reg regnum:dynamic-link)
+ 'SCHEME_OBJECT*)
+ (else
+ (comp-internal-error "Unknown machine register"
+ 'MACHINE-REGISTER-TYPE-SYMBOL reg))
+ |#
+ (else
+ 'SCHEME_OBJECT*)))
+
+(define-integrable (register-is-machine-register? reg)
+ (< reg number-of-machine-registers))
+
+(define (cast reg type)
+ (string-append "((" (type->name type) ") " reg ")"))
+
+(define permanent-register-list)
+(define current-register-list)
+
+(define (find-register reg type)
+ (let ((aliases (assq reg current-register-list)))
+ (and aliases
+ (let ((alias (assq type (cdr aliases))))
+ (cond (alias (cdr alias))
+ ((not type)
+ (cdadr aliases))
+ (else false))))))
+
+(define (standard-source! reg type)
+ (cond ((register-is-machine-register? reg)
+ (let ((name (machine-register-name reg)))
+ (if (eq? (machine-register-type-symbol reg) type)
+ name
+ (cast name type))))
+ ((find-register reg type))
+ ((find-register reg false)
+ => (lambda (reg)
+ (cast reg type)))
+ (else
+ (comp-internal-error "Unallocated register"
+ 'STANDARD-SOURCE! reg))))
+\f
+(define (standard-target! reg type)
+ (cond ((register-is-machine-register? reg)
+ (machine-register-name reg))
+ ((assq reg current-register-list)
+ => (lambda (aliases)
+ (let ((alias (assq type (cdr aliases))))
+ (if (or (not alias)
+ (not (null? (cddr aliases))))
+ (let ((name (new-register-name reg type)))
+ (set-cdr! aliases (list (cons type name)))
+ name)
+ (cdr alias)))))
+ (else
+ (let ((name (new-register-name reg type)))
+ (set! current-register-list
+ (cons (list reg (cons type name))
+ current-register-list))
+ name))))
+
+(define (new-register-name reg type)
+ (cond ((assq reg permanent-register-list)
+ => (lambda (aliases)
+ (let ((alias (assq type (cdr aliases))))
+ (if alias
+ (cdr alias)
+ (let ((name (reg*type->name reg type)))
+ (set-cdr! aliases
+ (cons (cons type name) (cdr aliases)))
+ name)))))
+ (else
+ (let ((name (reg*type->name reg type)))
+ (set! permanent-register-list
+ (cons (list reg (cons type name))
+ permanent-register-list))
+ name))))
+
+(define (register-declarations)
+ (append-map
+ (lambda (register)
+ (map (lambda (spec)
+ (string-append (type->name (car spec)) " " (cdr spec) ";\n\t"))
+ (cdr register)))
+ permanent-register-list))
+
+(define (standard-move-to-target! src tgt)
+ ;; This is bogus but we have no more information
+
+ (define (do-tgt src src-type)
+ (let ((tgt (standard-target! tgt src-type)))
+ (LAP ,tgt " = " ,src ";\n\t")))
+
+ (cond ((register-is-machine-register? src)
+ (do-tgt (machine-register-name src)
+ (machine-register-type-symbol src)))
+ ((assq src current-register-list)
+ => (lambda (aliases)
+ (let ((alias (cadr aliases)))
+ (do-tgt (cdr alias) (car alias)))))
+ (else
+ (comp-internal-error "Unallocated register"
+ 'STANDARD-MOVE-TO-TARGET! src))))
+\f
+;;;; Communicate with cout.scm
+
+(define (use-invoke-interface! number)
+ (set! *invoke-interface*
+ (let ((old *invoke-interface*))
+ (if (eq? old 'infinity)
+ number
+ (min old number)))))
+
+(define (use-invoke-primitive!)
+ (set! *used-invoke-primitive* true))
+
+(define (use-closure-interrupt-check!)
+ (use-invoke-interface! 0))
+
+(define (use-interrupt-check!)
+ (use-invoke-interface! 1))
+
+(define (use-dlink-interrupt-check!)
+ (use-invoke-interface! 2))
+
+(define (use-jump-execute-chache!)
+ (set! *use-jump-execute-chache* #t))
+
+(define (use-pop-return!)
+ (set! *use-pop-return* #t))
+\f
+;;;; Constants, Labels, and Various Caches
+
+(define-integrable make-entry cons)
+(define-integrable entry-value car)
+(define-integrable entry-label cdr)
+
+(define-integrable (make-table)
+ (cons 0 '()))
+
+(define-integrable table->list-of-entries cdr)
+
+(define (find-association table value)
+ (let ((x (assoc value (cdr table))))
+ (if x
+ (entry-label x)
+ #f)))
+
+(define (add-object! table name value)
+ (set-cdr! table
+ (cons (make-entry value name)
+ (cdr table)))
+ unspecific)
+
+(define (add-association! table value prefix)
+ (let ((num (car table)))
+ (add-object! table
+ (string-append prefix
+ *disambiguator*
+ (number->string num))
+ value)
+ (set-car! table (1+ num))
+ num))
+
+(define (find-or-add table value prefix)
+ (let ((x (find-association table value)))
+ (if x
+ x
+ (begin
+ (add-association! table value prefix)
+ (find-association table value)))))
+
+(define (define-object name value)
+ (add-object! objects
+ (if (symbol? name)
+ (symbol->string name)
+ name)
+ value))
+
+(define (object-label-value label)
+ (let ((entry
+ (list-search-positive (table->list-of-entries objects)
+ (lambda (entry)
+ (string=? label (entry-label entry))))))
+ (if (not entry)
+ (error "object-label-value: Unknown" label)
+ (entry-value entry))))
+
+(define objects)
+(define free-references)
+(define free-assignments)
+(define free-uuo-links)
+(define global-uuo-links)
+
+(define labels)
+(define label-num)
+
+(define (make-special-labels)
+ (define (frob name)
+ (string->uninterned-symbol (generate-new-label-symbol name)))
+
+ (vector (frob "ENVIRONMENT_LABEL_")
+ (frob "FREE_REFERENCES_LABEL_")
+ (frob "NUMBER_OF_LINKER_SECTIONS_")
+ (frob "DEBUGGING_LABEL_")))
+
+(define-integrable (special-label/environment)
+ (vector-ref *special-labels* 0))
+
+(define-integrable (special-label/free-references)
+ (vector-ref *special-labels* 1))
+
+(define-integrable (special-label/number-of-sections)
+ (vector-ref *special-labels* 2))
+
+(define-integrable (special-label/debugging)
+ (vector-ref *special-labels* 3))
+
+(define (prepare-constants-block)
+ (values (LAP)
+ (special-label/environment)
+ (special-label/free-references)
+ (special-label/number-of-sections)))
+
+(define (uuo-link-label table name frame-size prefix)
+ (define-integrable (uuo-link-label name)
+ name ; ignored
+ (generate-new-label-symbol prefix))
+
+ (let ((slot1 (assq name (cdr table))))
+ (if (not slot1)
+ (let ((label (uuo-link-label name)))
+ (set-cdr! table
+ (cons (list name (cons frame-size label))
+ (cdr table)))
+ label)
+ (let ((slot2 (assq frame-size (cdr slot1))))
+ (if (not slot2)
+ (let ((label (uuo-link-label name)))
+ (set-cdr! slot1
+ (cons (cons frame-size label)
+ (cdr slot1)))
+ label)
+ (cdr slot2))))))
+
+(define (free-uuo-link-label name frame-size)
+ (uuo-link-label free-uuo-links name frame-size "EXECUTE_CACHE_"))
+
+(define (global-uuo-link-label name frame-size)
+ (uuo-link-label global-uuo-links name frame-size "GLOBAL_EXECUTE_CACHE_"))
+
+;; this alias is for lapgn1.scm
+
+(define (constant->label object)
+ (declare (integrate object->offset))
+ (object->offset object))
+
+(define (object->offset scheme-object)
+ (find-or-add objects scheme-object "OBJECT_"))
+
+(define (free-reference->offset name)
+ (find-or-add free-references name "FREE_REFERENCE_"))
+
+(define (free-assignment->offset name)
+ (find-or-add free-assignments name "FREE_ASSIGNMENT_"))
+\f
+(define-integrable label-1 vector-first)
+(define-integrable label-2 vector-second)
+(define-integrable symbol-1 vector-third)
+(define-integrable symbol-2 vector-fourth)
+(define-integrable dispatch-1 vector-fifth)
+(define-integrable (set-dispatch-1! x d)
+ (vector-set! x 4 d))
+(define-integrable dispatch-2 vector-sixth)
+(define-integrable code-word-sel vector-seventh)
+
+(define (find-label label labels)
+ (let loop ((labels labels))
+ (and (not (null? labels))
+ (let ((next (car labels)))
+ (if (or (eq? label (label-1 next))
+ (eq? label (label-2 next)))
+ next
+ (loop (cdr labels)))))))
+
+(define (generate-new-label-symbol prefix)
+ (let ((num label-num))
+ (set! label-num (1+ num))
+ (string-append prefix
+ *disambiguator*
+ (number->string num))))
+
+(define (define-label! label)
+ (set! labels
+ (cons (vector label #f
+ (generate-new-label-symbol "LABEL_")
+ #f #f #f #f)
+ labels))
+ unspecific)
+
+(define (label->offset label)
+ (let ((x (find-label label labels)))
+ (if x
+ (symbol-1 x)
+ (begin
+ (define-label! label)
+ (label->offset label)))))
+
+(define (label->dispatch-tag label)
+ (let ((x (find-label label labels)))
+ (if x
+ (or (dispatch-1 x)
+ (let ((sym (generate-new-label-symbol "TAG_")))
+ (set-dispatch-1! x sym)
+ sym))
+ (begin
+ (define-label! label)
+ (label->dispatch-tag label)))))
+
+(define (declare-block-label! code-word label external-label)
+ (define (add-new-entry symbol-x symbol-y dispatch-x dispatch-y)
+ (set! labels
+ (cons (vector label external-label
+ symbol-x symbol-y
+ dispatch-x dispatch-y
+ code-word)
+ labels)))
+
+ (let ((x (and label (find-label label labels)))
+ (y (and external-label (find-label external-label labels))))
+ (if x
+ (set! labels (delq! x labels)))
+ (if y
+ (set! labels (delq! y labels)))
+ (cond ((and x (eq? x y))
+ (add-new-entry (symbol-1 x) (symbol-2 x)
+ (dispatch-1 x) (dispatch-2 x)))
+ ((and x y)
+ (add-new-entry (symbol-1 x) (symbol-1 y)
+ (dispatch-1 x) (dispatch-1 y)))
+ (x
+ (add-new-entry (symbol-1 x) #f
+ (dispatch-1 x) #f))
+ (y
+ (add-new-entry (symbol-1 y) #f
+ (dispatch-1 y) #f))
+ (else
+ (add-new-entry (generate-new-label-symbol "LABEL_")
+ #f
+ #f
+ #f)))
+ unspecific))
+\f
+(define available-machine-registers
+ ;; This is really a lie, but lets some things work
+ (list
+ regnum:stack-pointer regnum:regs regnum:free
+ regnum:dynamic-link regnum:value))
+
+(define (sort-machine-registers lst)
+ lst)
+
+(define (register-type reg)
+ (comp-internal-error "Should not be using register allocator"
+ 'REGISTER-TYPE reg))
+
+(define (register-types-compatible? x y)
+ (comp-internal-error "Should not be using register allocator"
+ 'REGISTER-TYPES-COMPATIBLE? x y))
+
+(define (register-reference num)
+ (comp-internal-error "Should not be using register allocator"
+ 'REGISTER-REFERENCE num))
+
+(define (register->register-transfer one two)
+ (comp-internal-error "Should not be using register allocator"
+ 'REGISTER->REGISTER-TRANSFER one two))
+
+(define (reference->register-transfer one two)
+ (comp-internal-error "Should not be using register allocator"
+ 'REFERENCE->REGISTER-TRANSFER one two))
+
+(define (pseudo-register-home one)
+ (comp-internal-error "Should not be using register allocator"
+ 'PSEUDO-REGISTER-HOME one))
+
+(define (home->register-transfer one two)
+ (comp-internal-error "Should not be using register allocator"
+ 'HOME->REGISTER-TRANSFER one two))
+
+(define (register->home-transfer one two)
+ (comp-internal-error "Should not be using register allocator"
+ 'REGISTER->HOME-TRANSFER one two))
+
+(define (lap:make-label-statement label)
+ (LAP "\n" ,label ":\n\t" ))
+
+(define (lap:make-unconditional-branch label)
+ (LAP "goto " ,label ";\n\t"))
+
+(define (lap:make-entry-point label block-start-label)
+ block-start-label ; ignored
+ (declare-block-label! expression-code-word label #f)
+ (lap:make-label-statement label))
+
+(define (compare cc val1 val2)
+ (set-current-branches!
+ (lambda (label)
+ (LAP "if (" ,val1 ,cc ,val2 ")\n\t goto " ,label ";\n\t"))
+ (lambda (label)
+ (LAP "if (!(" ,val1 ,cc ,val2 "))\n\t goto " ,label ";\n\t")))
+ (LAP))
+\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))
+ (comp-internal-error "Unknown operator" 'LOOKUP-ARITHMETIC-METHOD
+ operator))))
+
+(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))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: machin.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Machine Model for C
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;;; Architecture Parameters
+
+(define use-pre/post-increment? true)
+(define endianness 'DONT-KNOW)
+(define scheme-object-width "OBJECT_LENGTH")
+(define scheme-type-width "TYPE_CODE_LENGTH")
+
+(define scheme-datum-width "DATUM_LENGTH")
+
+;;; 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 address-units-per-object "ADDRESS_UNITS_PER_OBJECT")
+
+(define-integrable address-units-per-packed-char 1)
+
+;; We expect a C long to be at least 32 bits wide,
+;; but not necessarily two's complement.
+
+(define-integrable min-long-width 32)
+(define-integrable max-tag-width 8)
+
+(define-integrable guaranteed-long/upper-limit
+ (expt 2 min-long-width))
+(define-integrable guaranteed-long/lower-limit
+ (- (-1+ guaranteed-long/upper-limit)))
+
+(define signed-fixnum/upper-limit
+ (expt 2 (- min-long-width (1+ max-tag-width))))
+(define signed-fixnum/lower-limit
+ (- 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:
+ ;; Format + GC offset word
+ ;; C procedure descriptor + switch tag
+ ;; pointer to code block
+ 3)
+
+;; 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)))
+
+;; Like the above, but from the start of the complete closure object,
+;; viewed as a vector, and including the header word.
+
+(define (closure-object-first-offset nentries)
+ (case nentries
+ ((0)
+ ;; Vector header only
+ 1)
+ ((1)
+ ;; Manifest closure header followed by single entry point
+ (+ 1 closure-entry-size))
+ (else
+ ;; Manifest closure header, number of entries, then entries.
+ (+ 1 1 (* closure-entry-size nentries)))))
+
+;; Bump from one entry point to another -- distance in BYTES
+
+(define (closure-entry-distance nentries entry entry*) ; for now
+ nentries ; ignored
+ (let ((entry-delta (- entry* entry)))
+ (if (zero? entry-delta)
+ 0
+ (string-append "((sizeof (SCHEME_OBJECT)) * "
+ (number->string
+ (* closure-entry-size entry-delta))
+ ")"))))
+
+;; Bump to the canonical entry point. On a RISC (which forces
+;; longword alignment for entry points anyway) there is no need to
+;; canonicalize.
+
+(define (closure-environment-adjustment nentries entry)
+ nentries entry ; ignored
+ 0)
+\f
+;;;; Machine Registers
+
+(define-integrable number-of-machine-registers 5) ; for now
+(define-integrable number-of-temporary-registers 1000000) ; enough?
+
+;;; Fixed-use registers for Scheme compiled code.
+(define-integrable regnum:regs 0)
+(define-integrable regnum:stack-pointer 1)
+(define-integrable regnum:free 2)
+(define-integrable regnum:dynamic-link 3)
+(define-integrable regnum:value 4)
+
+;;; Fixed-use registers due to architecture or OS calling conventions.
+
+(define machine-register-value-class
+ (let ((special-registers
+ `((,regnum:stack-pointer . ,value-class=address)
+ (,regnum:regs . ,value-class=unboxed)
+ (,regnum:free . ,value-class=address)
+ (,regnum:dynamic-link . ,value-class=address)
+ (,regnum:value . ,value-class=object))))
+
+ (lambda (register)
+ (let ((lookup (assv register special-registers)))
+ (cond
+ ((not (null? lookup)) (cdr lookup))
+ (else (error "illegal machine register" register)))))))
+
+(define-integrable (machine-register-known-value register)
+ register ;ignore
+ false)
+\f
+;;;; Interpreter Registers
+
+(define-integrable register-block/memtop-offset 0)
+(define-integrable register-block/value-offset 2)
+(define-integrable register-block/environment-offset 3)
+(define-integrable register-block/dynamic-link-offset 4) ; compiler temp
+(define-integrable register-block/lexpr-primitive-arity-offset 7)
+(define-integrable register-block/utility-arg4-offset 9) ; closure free
+(define-integrable register-block/stack-guard-offset 11)
+
+(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))
+
+(define (interpreter-regs-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:regs)))
+
+(define-integrable (interpreter-value-register)
+ #|
+ (rtl:make-offset (interpreter-regs-pointer)
+ register-block/value-offset)
+ |#
+ (rtl:make-machine-register regnum:value))
+
+(define (interpreter-value-register? expression)
+ #|
+ (and (rtl:offset? expression)
+ (interpreter-regs-pointer? (rtl:offset-base expression))
+ (= (rtl:offset-number expression) register-block/value-offset))
+ |#
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum: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)
+ register-block/environment-offset))
+
+(define (interpreter-environment-register? expression)
+ (and (rtl:offset? expression)
+ (interpreter-regs-pointer? (rtl:offset-base expression))
+ (= register-block/environment-offset (rtl:offset-number expression))))
+
+(define-integrable (interpreter-register:access)
+ (interpreter-value-register))
+
+(define-integrable (interpreter-register:cache-reference)
+ (interpreter-value-register))
+
+(define-integrable (interpreter-register:cache-unassigned?)
+ (interpreter-value-register))
+
+(define-integrable (interpreter-register:lookup)
+ (interpreter-value-register))
+
+(define-integrable (interpreter-register:unassigned?)
+ (interpreter-value-register))
+
+(define-integrable (interpreter-register:unbound?)
+ (interpreter-value-register))
+\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)
+ register-block/memtop-offset)
+ ((STACK-GUARD)
+ register-block/stack-guard-offset)
+ ((ENVIRONMENT)
+ register-block/environment-offset)
+ #|
+ ((VALUE)
+ register-block/value-offset)
+ ((INTERPRETER-CALL-RESULT:ACCESS)
+ register-block/value-offset)
+ ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
+ register-block/value-offset)
+ ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
+ register-block/value-offset)
+ ((INTERPRETER-CALL-RESULT:LOOKUP)
+ register-block/value-offset)
+ ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
+ register-block/value-offset)
+ ((INTERPRETER-CALL-RESULT:UNBOUND?)
+ register-block/value-offset)
+ |#
+ (else
+ false)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown register type" locative)))
+
+(define (rtl:constant-cost expression)
+ expression ; ignored
+ 1)
+
+(define compiler:open-code-floating-point-arithmetic?
+ true)
+
+(define compiler:primitives-with-no-open-coding
+ '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS
+ FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND
+ FLONUM-REMAINDER FLONUM-SQRT))
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: make.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler: System Construction
+
+(declare (usual-integrations))
+
+(let ((value ((load "base/make") "C")))
+ (set! (access compiler:compress-top-level? (->environment '(compiler)))
+ true)
+ value)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rgspcm.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Generation: Special primitive combinations.
+
+(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 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Data Transfers
+;;; package: (compiler lap-syntaxer)
+
+(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))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (let* ((datum (standard-source! datum 'SCHEME_OBJECT*))
+ (type (standard-source! type 'ULONG))
+ (target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", " ,datum "));\n\t")))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-NON-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (let* ((datum (standard-source! datum 'SCHEME_OBJECT*))
+ (type (standard-source! type 'ULONG))
+ (target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = (MAKE_OBJECT (" ,type ", " ,datum "));\n\t")))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
+ (let* ((datum (standard-source! source 'SCHEME_OBJECT*))
+ (target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", " ,datum "));\n\t")))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
+ (let* ((datum (standard-source! source 'LONG))
+ (target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = (MAKE_OBJECT (" ,type ", " ,datum "));\n\t")))
+
+(define (standard-unary-conversion source source-type target target-type
+ conversion)
+ (let* ((source (standard-source! source source-type))
+ (target (standard-target! target target-type)))
+ (conversion source target)))
+
+(define (standard-binary-conversion source1 source1-type source2 source2-type
+ target target-type conversion)
+ (let* ((source1 (standard-source! source1 source1-type))
+ (source2 (standard-source! source2 source2-type))
+ (target (standard-target! target target-type)))
+ (conversion source1 source2 target)))
+
+(define (object->type source target)
+ (LAP ,target " = (OBJECT_TYPE (" ,source "));\n\t"))
+
+(define (object->datum source target)
+ (LAP ,target " = (OBJECT_DATUM (" ,source "));\n\t"))
+
+(define (object->address source target)
+ (LAP ,target " = (OBJECT_ADDRESS (" ,source "));\n\t"))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (standard-unary-conversion source 'SCHEME_OBJECT target 'ULONG
+ object->type))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+ (standard-unary-conversion source 'SCHEME_OBJECT target 'ULONG
+ object->datum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (standard-unary-conversion source 'SCHEME_OBJECT target 'SCHEME_OBJECT*
+ object->address))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
+ (standard-unary-conversion
+ source 'SCHEME_OBJECT* target 'SCHEME_OBJECT*
+ (lambda (source target)
+ (LAP ,target " = &" ,source "[" ,offset "];\n\t"))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
+ (standard-unary-conversion
+ source 'CHAR* target 'CHAR*
+ (lambda (source target)
+ (LAP ,target " = &" ,source "[" ,offset "];\n\t"))))
+\f
+;;;; Loading of Constants
+
+(define-rule statement
+ ;; load a machine constant
+ (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
+ (let ((target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = ((SCHEME_OBJECT) " ,source ");\n\t")))
+
+(define-rule statement
+ ;; load a Scheme constant
+ (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
+ (let ((target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = current_block[" ,(object->offset source) "];\n\t")))
+
+(define-rule statement
+ ;; load the type part of a Scheme constant
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
+ (let ((target (standard-target! target 'ULONG)))
+ (LAP ,target " = (OBJECT_TYPE (current_block["
+ ,(object->offset constant) "]));\n\t")))
+
+(define-rule statement
+ ;; load the datum part of a Scheme constant
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
+ (QUALIFIER (non-pointer-object? constant))
+ (let ((target (standard-target! target 'ULONG)))
+ (LAP ,target " = (OBJECT_DATUM (current_block["
+ ,(object->offset constant) "]));\n\t")))
+
+(define-rule statement
+ ;; load a synthesized constant
+ (ASSIGN (REGISTER (? target))
+ (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (let((target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = (MAKE_OBJECT (" ,type ", " ,datum "));\n\t")))
+\f
+(define-rule statement
+ ;; load the address of a variable reference cache
+ (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+ (let ((target (standard-target! target 'SCHEME_OBJECT*)))
+ (LAP ,target " = ((SCHEME_OBJECT *) current_block["
+ ,(free-reference->offset name) "]);\n\t")))
+
+(define-rule statement
+ ;; load the address of an assignment cache
+ (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
+ (let ((target (standard-target! target 'SCHEME_OBJECT*)))
+ (LAP ,target " = ((SCHEME_OBJECT *) current_block["
+ ,(free-assignment->offset name) "]);\n\t")))
+
+(define-rule statement
+ ;; load the address of a procedure's entry point
+ (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
+ (let ((target (standard-target! target 'SCHEME_OBJECT*)))
+ (LAP ,target " = ¤t_block[" ,(label->offset label) "];\n\t")))
+
+(define-rule statement
+ ;; load the address of a continuation
+ (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
+ (let ((target (standard-target! target 'SCHEME_OBJECT*)))
+ (LAP ,target " = ¤t_block[" ,(label->offset label) "];\n\t")))
+
+(define-rule statement
+ ;; load a procedure object
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:PROCEDURE (? label))))
+ (let ((target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", ¤t_block["
+ ,(label->offset label) "]));\n\t")))
+
+(define-rule statement
+ ;; load a return address object
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:CONTINUATION (? label))))
+ (let ((target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", ¤t_block["
+ ,(label->offset label) "]));\n\t")))
+\f
+;;;; Transfers from memory
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
+ (standard-unary-conversion address 'SCHEME_OBJECT* target 'SCHEME_OBJECT
+ (lambda (address target)
+ (LAP ,target " = " ,address "[" ,offset "];\n\t"))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? rsp)) 1))
+ (QUALIFIER (= rsp regnum:stack-pointer))
+ (let ((target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP ,target " = *stack_pointer++;\n\t")))
+
+;;;; Transfers to memory
+
+(define-rule statement
+ ;; store an object in memory
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (REGISTER (? source)))
+ (let* ((source (standard-source! source 'SCHEME_OBJECT))
+ (address (standard-source! address 'SCHEME_OBJECT*)))
+ (LAP ,address "[" ,offset "] = " ,source ";\n\t")))
+
+(define-rule statement
+ ;; Push an object register on the heap
+ (ASSIGN (POST-INCREMENT (REGISTER (? rfree)) 1)
+ (REGISTER (? source)))
+ (QUALIFIER (= rfree regnum:free))
+ (let ((source (standard-source! source 'SCHEME_OBJECT)))
+ (LAP "*free_pointer++ = " ,source ";\n\t")))
+
+(define-rule statement
+ ;; Push an object register on the stack
+ (ASSIGN (PRE-INCREMENT (REGISTER (? rsp)) -1)
+ (REGISTER (? source)))
+ (QUALIFIER (= rsp regnum:stack-pointer))
+ (let ((source (standard-source! source 'SCHEME_OBJECT)))
+ (LAP "*--stack_pointer = " ,source ";\n\t")))
+
+;; Cheaper, common patterns.
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (MACHINE-CONSTANT 0))
+ (let ((address (standard-source! address 'SCHEME_OBJECT*)))
+ (LAP ,address "[" ,offset "] = ((SCHEME_OBJECT) 0);\n\t")))
+
+(define-rule statement
+ ; Push NIL (or whatever is represented by a machine 0) on heap
+ (ASSIGN (POST-INCREMENT (REGISTER (? rfree)) 1) (MACHINE-CONSTANT 0))
+ (QUALIFIER (= rfree regnum:free))
+ (LAP "*free_pointer++ = ((SCHEME_OBJECT) 0);\n\t"))
+
+(define-rule statement
+ ;; Push an object register on the stack
+ (ASSIGN (PRE-INCREMENT (REGISTER (? rsp)) -1)
+ (MACHINE-CONSTANT (? const)))
+ (QUALIFIER (= rsp regnum:stack-pointer))
+ (LAP "*--stack_pointer = ((SCHEME_OBJECT) " ,const ");\n\t"))
+\f
+;;;; CHAR->ASCII/BYTE-OFFSET
+
+(define-rule statement
+ ;; load char object from memory and convert to ASCII byte
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
+ (standard-unary-conversion address 'SCHEME_OBJECT* target 'ULONG
+ (lambda (address target)
+ (LAP ,target " = (CHAR_TO_ASCII (" ,address "[" ,offset "]));\n\t"))))
+
+(define-rule statement
+ ;; load ASCII byte from memory
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET (REGISTER (? address)) (? offset)))
+ (standard-unary-conversion address 'CHAR* target 'ULONG
+ (lambda (address target)
+ (LAP ,target " = ((ulong) (((unsigned char *) " ,address ")["
+ ,offset "]));\n\t"))))
+
+(define-rule statement
+ ;; convert char object to ASCII byte
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (REGISTER (? source))))
+ (standard-unary-conversion source 'SCHEME_OBJECT target 'ULONG
+ (lambda (source target)
+ (LAP ,target " = (CHAR_TO_ASCII (" ,source "));\n\t"))))
+
+(define-rule statement
+ ;; store null byte in memory
+ (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (CHAR->ASCII (CONSTANT #\N\TUL)))
+ (let ((address (standard-source! address 'CHAR*)))
+ (LAP ,address "[" ,offset "] = '\\0';\n\t")))
+
+(define-rule statement
+ ;; store ASCII byte in memory
+ (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (REGISTER (? source)))
+ (let ((address (standard-source! address 'CHAR*))
+ (source (standard-source! source 'ULONG)))
+ (LAP ,address "[" ,offset "] = ((char) " ,source ");\n\t")))
+
+(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 ((address (standard-source! address 'CHAR*))
+ (source (standard-source! source 'SCHEME_OBJECT)))
+ (LAP ,address "[" ,offset "] = ((char) (CHAR_TO_ASCII (" ,source
+ ")));\n\t")))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules2.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Predicates
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define-rule predicate
+ ;; test for two registers EQ?
+ (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
+ (let ((source1 (standard-source! source1 'SCHEME_OBJECT))
+ (source2 (standard-source! source2 'SCHEME_OBJECT)))
+ (set-current-branches!
+ (lambda (if-true-label)
+ (LAP "if (" ,source1 " == " ,source2 ")\n\t goto "
+ ,if-true-label ";\n\t"))
+ (lambda (if-false-label)
+ (LAP "if (" ,source1 " != " ,source2 ")\n\t goto "
+ ,if-false-label ";\n\t")))
+ (LAP)))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (CONSTANT (? constant)) (REGISTER (? source)))
+ (eq-test/constant constant source))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (REGISTER (? source)) (CONSTANT (? constant)))
+ (eq-test/constant constant source))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (MACHINE-CONSTANT (? constant)) (REGISTER (? source)))
+ (eq-test/machine-constant constant source))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (REGISTER (? source)) (MACHINE-CONSTANT (? constant)))
+ (eq-test/machine-constant constant source))
+
+(define-rule predicate
+ ;; test for register EQ? to synthesized constant
+ (EQ-TEST (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (REGISTER (? source)))
+ (eq-test/non-pointer type datum source))
+
+(define-rule predicate
+ ;; test for register EQ? to synthesized constant
+ (EQ-TEST (REGISTER (? source))
+ (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (eq-test/non-pointer type datum source))
+
+(define-rule predicate
+ ;; Branch if virtual register contains the specified type number
+ (TYPE-TEST (REGISTER (? source)) (? type))
+ (let ((source (standard-source! source 'ULONG)))
+ (set-current-branches!
+ (lambda (if-true-label)
+ (LAP "if (" ,source " == " ,type ")\n\t goto " ,if-true-label
+ ";\n\t"))
+ (lambda (if-false-label)
+ (LAP "if (" ,source " != " ,type ")\n\t goto " ,if-false-label
+ ";\n\t")))
+ (LAP)))
+
+(define (eq-test/constant constant source)
+ (let ((source (standard-source! source 'SCHEME_OBJECT)))
+ (set-current-branches!
+ (lambda (if-true-label)
+ (LAP "if (" ,source " == current_block[" ,(object->offset constant)
+ "])\n\t goto " ,if-true-label ";\n\t"))
+ (lambda (if-false-label)
+ (LAP "if (" ,source " != current_block[" ,(object->offset constant)
+ "])\n\t goto " ,if-false-label ";\n\t")))
+ (LAP)))
+
+(define (eq-test/machine-constant constant source)
+ (let ((source (standard-source! source 'SCHEME_OBJECT)))
+ (set-current-branches!
+ (lambda (if-true-label)
+ (LAP "if (" ,source " == ((SCHEME_OBJECT) " ,constant "))\n\t goto "
+ ,if-true-label ";\n\t"))
+ (lambda (if-false-label)
+ (LAP "if (" ,source " != ((SCHEME_OBJECT) " ,constant "))\n\t goto "
+ ,if-false-label ";\n\t")))
+ (LAP)))
+
+(define (eq-test/non-pointer type datum source)
+ (let ((source (standard-source! source 'SCHEME_OBJECT)))
+ (set-current-branches!
+ (lambda (if-true-label)
+ (LAP "if (" ,source " == (MAKE_OBJECT (" ,type ", " ,datum
+ ")))\n\t goto " ,if-true-label ";\n\t"))
+ (lambda (if-false-label)
+ (LAP "if (" ,source " != (MAKE_OBJECT (" ,type ", " ,datum
+ ")))\n\t goto " ,if-false-label ";\n\t")))
+ (LAP)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules3.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Invocations
+
+(define (pop-return)
+ (use-pop-return!)
+ (LAP ,@(clear-map!)
+ "POP_RETURN();\n\t"))
+
+(define-rule statement
+ (POP-RETURN)
+ (pop-return))
+
+(define-rule statement
+ (INVOCATION:APPLY (? frame-size) (? continuation))
+ continuation ;ignore
+ (let ()
+ (use-invoke-interface! 2)
+ (LAP ,@(clear-map!)
+ "{\n\t SCHEME_OBJECT procedure = *stack_pointer++;\n\t"
+ " INVOKE_INTERFACE_2 (" ,code:compiler-apply ", procedure, "
+ ,frame-size ");\n\t}\n\t")))
+
+(define-rule statement
+ (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+ frame-size continuation ;ignore
+ (LAP ,@(clear-map!)
+ "goto " ,label ";\n\t"))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
+ frame-size continuation ;ignore
+ (pop-return))
+
+(define-rule statement
+ (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
+ continuation ;ignore
+ (let ()
+ (use-invoke-interface! 2)
+ (LAP ,@(clear-map!)
+ "{\n\t SCHEME_OBJECT * procedure_address = ¤t_block["
+ ,(label->offset label)
+ "];\n\t INVOKE_INTERFACE_2 (" ,code:compiler-lexpr-apply
+ ", procedure_address, " ,number-pushed ");\n\t}\n\t")))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
+ continuation ;ignore
+ ;; Destination address is at TOS; pop it into second-arg
+ (let ()
+ (use-invoke-interface! 2)
+ (LAP ,@(clear-map!)
+ "{n\t SCHEME_OBJECT procedure = *stack_pointer++;\n\t "
+ "SCHEME_OBJECT * procedure_address = (OBJECT_ADDRESS (procedure));\n\t"
+ " INVOKE_INTERFACE_2 (" ,code:compiler-lexpr-apply
+ ", procedure_address, " ,number-pushed ");\n\t}\n\t")))
+\f
+(define-rule statement
+ (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
+ continuation ;ignore
+ (begin
+ (use-jump-execute-chache!)
+ (LAP ,@(clear-map!)
+ "JUMP_EXECUTE_CHACHE (" ,(free-uuo-link-label name frame-size) ");\n\t")))
+
+(define-rule statement
+ (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
+ continuation ;ignore
+ (begin
+ (use-jump-execute-chache!)
+ (LAP ,@(clear-map!)
+ "JUMP_EXECUTE_CHACHE (" ,(global-uuo-link-label name frame-size) ");\n\t")))
+
+(define-rule statement
+ (INVOCATION:CACHE-REFERENCE (? frame-size)
+ (? continuation)
+ (REGISTER (? extension)))
+ continuation ;ignore
+ (let ((extension (standard-source! extension 'SCHEME_OBJECT*)))
+ (use-invoke-interface! 3)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_3 (" ,code:compiler-cache-reference-apply
+ ", " ,extension ", current_block, " ,frame-size ");\n\t")))
+
+(define-rule statement
+ (INVOCATION:LOOKUP (? frame-size)
+ (? continuation)
+ (REGISTER (? environment))
+ (? name))
+ continuation ;ignore
+ (let ((environment (standard-source! environment 'SCHEME_OBJECT)))
+ (use-invoke-interface! 3)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_3 (" ,code:compiler-lookup-apply
+ ", " ,environment ", current_block[" ,(object->offset name) "]"
+ ", " ,frame-size ");\n\t")))
+\f
+(define-rule statement
+ (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
+ continuation ;ignore
+ (cond ((eq? primitive compiled-error-procedure)
+ (use-invoke-interface! 1)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_1 (" ,code:compiler-error ", "
+ ,frame-size ");\n\t"))
+ (else
+ (let ((arity (primitive-procedure-arity primitive)))
+ (cond ((= arity (-1+ frame-size))
+ (use-invoke-primitive!)
+ (LAP ,@(clear-map!)
+ "INVOKE_PRIMITIVE (current_block["
+ ,(object->offset primitive) "], "
+ ,arity
+ ");\n\t"))
+ #|
+ ((= arity -1)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_2 (" ,code:compiler-apply
+ ", (current_block[" ,(object->offset primitive) "]"
+ ", " ,frame-size ");\n\t"))
+ |#
+ (else
+ (if (not (= arity -1))
+ (error "Wrong number of arguments to primitive"
+ primitive (-1+ frame-size)))
+ (use-invoke-interface! 2)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_2 (" ,code:compiler-apply
+ ", current_block[" ,(object->offset primitive) "]"
+ ", " ,frame-size ");\n\t")))))))
+
+(define (invoke-special-primitive code)
+ (use-invoke-interface! 0)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_0 (" ,code ");\n\t"))
+
+(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
+ (invoke-special-primitive
+ ,(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 ,regnum:stack-pointer))
+ (LAP))
+
+(define-rule statement
+ ;; Move <frame-size> words back to dynamic link marker
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? new-frame)))
+ (let ((new-frame (standard-source! new-frame 'SCHEME_OBJECT*)))
+ (move-frame-up frame-size new-frame "")))
+
+(define (move-frame-up frame-size new-frame pfx)
+ (case frame-size
+ ((0)
+ (LAP ,pfx "stack_pointer = " ,new-frame ";\n\t"))
+ ((1)
+ (LAP ,pfx "*--" ,new-frame " = stack_pointer[0];\n\t"
+ ,pfx "stack_pointer = " ,new-frame ";\n\t"))
+ ((2)
+ (LAP ,pfx "*--" ,new-frame " = stack_pointer[1];\n\t"
+ ,pfx "*--" ,new-frame " = stack_pointer[0];\n\t"
+ ,pfx "stack_pointer = " ,new-frame ";\n\t"))
+ ((3)
+ (LAP ,pfx "*--" ,new-frame " = stack_pointer[2];\n\t"
+ ,pfx "*--" ,new-frame " = stack_pointer[1];\n\t"
+ ,pfx "*--" ,new-frame " = stack_pointer[0];\n\t"
+ ,pfx "stack_pointer = " ,new-frame ";\n\t"))
+ (else
+ (LAP ,pfx "{\n\t SCHEME_OBJECT * frame_top = &stack_pointer["
+ ,frame-size "];\n\t"
+ ,pfx " long frame_size = " ,frame-size ";\n\t"
+ ,pfx " while ((--frame_size) >= 0)"
+ ,pfx " *--" ,new-frame " = *--frame_top;\n\t"
+ ,pfx " stack_pointer = " ,new-frame ";\n\t"
+ ,pfx "}\n\t"))))
+\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 (? choice-1))
+ (REGISTER (? choice-2)))
+ (let ((choice-1 (standard-source! choice-1 'SCHEME_OBJECT*))
+ (choice-2 (standard-source! choice-2 'SCHEME_OBJECT*)))
+ (LAP "{\n\t SCHEME_OBJECT * new_frame;\n\t"
+ " new_frame = ((" ,choice-1 " <= " ,choice-2 ") ? "
+ ,choice-1 " : " ,choice-2 ");\n\t"
+ ,@(move-frame-up frame-size "new_frame" " ")
+ "}\n\t")))
+\f
+;;; 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 e-label code)
+ (declare-block-label! code-word label e-label)
+ (let ((block-label (label->offset label)))
+ (use-interrupt-check!)
+ (LAP ,@(if (not e-label)
+ (LAP)
+ (label-statement e-label))
+ ,@(label-statement label)
+ "INTERRUPT_CHECK (" ,code ", (" ,block-label "));\n\t")))
+
+(define (dlink-procedure-header code-word label e-label)
+ (declare-block-label! code-word label e-label)
+ (let ((block-label (label->offset label)))
+ (use-dlink-interrupt-check!)
+ (LAP ,@(if (not e-label)
+ (LAP)
+ (label-statement e-label))
+ ,@(label-statement label)
+ "DLINK_INTERRUPT_CHECK ("
+ ,code:compiler-interrupt-dlink
+ ", (" ,block-label "));\n\t")))
+
+(define-rule statement
+ (CONTINUATION-ENTRY (? internal-label))
+ (declare-block-label! (continuation-code-word internal-label)
+ internal-label #f)
+ (label-statement internal-label))
+
+(define-rule statement
+ (CONTINUATION-HEADER (? internal-label))
+ (simple-procedure-header (continuation-code-word internal-label)
+ internal-label
+ #f
+ code:compiler-interrupt-continuation))
+
+(define-rule statement
+ (IC-PROCEDURE-HEADER (? internal-label))
+ (simple-procedure-header expression-code-word
+ internal-label
+ (rtl-procedure/external-label
+ (label->object internal-label))
+ code:compiler-interrupt-ic-procedure))
+
+(define-rule statement
+ (OPEN-PROCEDURE-HEADER (? internal-label))
+ (let* ((rtl-proc (label->object internal-label))
+ (external-label (rtl-procedure/external-label rtl-proc)))
+ ((if (rtl-procedure/dynamic-link? rtl-proc)
+ dlink-procedure-header
+ (lambda (code-word label external-label)
+ (simple-procedure-header code-word label external-label
+ code:compiler-interrupt-procedure)))
+ (internal-procedure-code-word rtl-proc)
+ internal-label external-label)))
+
+(define-rule statement
+ (PROCEDURE-HEADER (? internal-label) (? min) (? max))
+ (simple-procedure-header (make-procedure-code-word min max)
+ internal-label
+ (rtl-procedure/external-label
+ (label->object internal-label))
+ code:compiler-interrupt-procedure))
+\f
+;;;; Closures.
+
+;; Magic for compiled entries.
+
+(define-integrable (label-statement label)
+ (lap:make-label-statement label))
+
+(define-rule statement
+ (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+ entry
+ (if (zero? nentries)
+ (error "Closure header for closure with no entries!"
+ internal-label))
+ (let ((rtl-proc (label->object internal-label)))
+ (let ((external-label (rtl-procedure/external-label rtl-proc)))
+ (declare-block-label! (internal-procedure-code-word rtl-proc)
+ #f external-label)
+ (use-closure-interrupt-check!)
+ (LAP ,@(label-statement external-label)
+ "CLOSURE_HEADER (" ,(label->offset external-label) ");\n\t"
+ ,@(label-statement internal-label)
+ "CLOSURE_INTERRUPT_CHECK ("
+ ,(number->string code:compiler-interrupt-closure)
+ ");\n\t"))))
+
+(define (build-gc-offset-word offset code-word)
+ (let ((encoded-offset (quotient offset 2)))
+ (if (eq? endianness 'LITTLE)
+ (+ (* encoded-offset #x10000) code-word)
+ (+ (* code-word #x10000) encoded-offset))))
+
+(define (write-closure-entry internal-label min max offset)
+ (let ((external-label
+ (rtl-procedure/external-label (label->object internal-label))))
+ (LAP "WRITE_LABEL_DESCRIPTOR (free_pointer, 0x"
+ ,(number->string (make-procedure-code-word min max) 16) ", "
+ ,offset ");\n\t"
+ "free_pointer[0] = (MAKE_LABEL_WORD (current_C_proc, "
+ ,(label->dispatch-tag external-label)
+ "));\n\t"
+ "free_pointer[1] = ((SCHEME_OBJECT) (¤t_block["
+ ,(label->offset external-label) "]));\n\t")))
+
+(define (cons-closure target label min max nvars)
+ (let ((target (standard-target! target 'SCHEME_OBJECT*)))
+ (LAP "* free_pointer = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", "
+ ,(+ closure-entry-size nvars) "));\n\t"
+ "free_pointer += 2;\n\t"
+ ,target " = free_pointer;\n\t"
+ ,@(write-closure-entry label min max 2)
+ "free_pointer += " ,(+ nvars 2) ";\n\t")))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+ (? min) (? max) (? nvars)))
+ (cons-closure target procedure-label min max nvars))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-MULTICLOSURE (? nentries) (? nvars) (? entries)))
+ ;; entries is a vector of all the entry points
+ (case nentries
+ ((0)
+ (let ((dest (standard-target! target 'SCHEME_OBJECT*)))
+ (LAP ,dest " = free_pointer;\n\t"
+ "*free_pointer = (MAKE_OBJECT (" ,(ucode-type manifest-vector)
+ ", " ,nvars "));\n\t"
+ "free_pointer += " ,(+ nvars 1) ";\n\t")))
+ ((1)
+ (let ((entry (vector-ref entries 0)))
+ (cons-closure target (car entry) (cadr entry) (caddr entry) nvars)))
+ (else
+ (cons-multiclosure target nentries nvars (vector->list entries)))))
+
+(define (cons-multiclosure target nentries nvars entries)
+ (let ((target (standard-target! target 'SCHEME_OBJECT*)))
+ (LAP "* free_pointer = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", "
+ ,(1+ (+ (* nentries closure-entry-size) nvars)) "));\n\t"
+ "free_pointer += 2;\n\t"
+ "WRITE_LABEL_DESCRIPTOR (free_pointer, " ,nentries ", 0);\n\t"
+ "free_pointer += 1;\n\t"
+ ,target " = free_pointer;\n\t"
+ ,@(reduce-right
+ (lambda (lap1 lap2)
+ (LAP ,@lap1 ,@lap2))
+ (LAP)
+ (map (lambda (entry offset)
+ (let ((label (car entry))
+ (min (cadr entry))
+ (max (caddr entry)))
+ (LAP ,@(write-closure-entry label min max offset)
+ "free_pointer += 3;\n\t")))
+ entries (make-multiclosure-offsets nentries)))
+ "free_pointer += " ,(- nvars 1) ";\n\t")))
+
+(define (make-multiclosure-offsets nentries)
+ (let generate ((x nentries)
+ (offset 3))
+ (if (= 0 x)
+ '()
+ (cons offset
+ (generate (-1+ x)
+ (+ offset closure-entry-size))))))
+\f
+;;;; Entry Header
+;;; This is invoked by the top level of the LAP generator.
+
+(define (generate/quotation-header environment-label
+ free-ref-offset n-sections)
+ (let ((label (generate-label)))
+ (declare-block-label! (continuation-code-word false) false label)
+ (use-invoke-interface! 4)
+ (LAP "current_block[" ,environment-label
+ "] = register_block[REGBLOCK_ENV];\n\t"
+ "INVOKE_INTERFACE_4 (" ,code:compiler-link
+ ", ¤t_block[" ,(label->offset label) "]"
+ ",\n\t\t\t\tcurrent_block"
+ ",\n\t\t\t\t¤t_block[" ,free-ref-offset "]"
+ ",\n\t\t\t\t" ,n-sections ");\n\t"
+ ,@(label-statement label))))
+
+(define (generate/remote-link code-block-label
+ environment-offset
+ free-ref-offset
+ n-sections)
+ (let ((label (generate-label)))
+ (add-remote-link! code-block-label)
+ (declare-block-label! (continuation-code-word false) false label)
+ (use-invoke-interface! 4)
+ (LAP "{\n\t SCHEME_OBJECT * subblock = (OBJECT_ADDRESS (current_block["
+ ,code-block-label "]));\n\t "
+ "subblock[" ,environment-offset
+ "] = register_block[REGBLOCK_ENV];\n\t "
+ "INVOKE_INTERFACE_4 (" ,code:compiler-link
+ ", ¤t_block[" ,(label->offset label) "]"
+ ",\n\t\t\t\t subblock"
+ ",\n\t\t\t\t &subblock[" ,free-ref-offset "]"
+ ",\n\t\t\t\t" ,n-sections ");\n\t}\n\t"
+ ,@(label-statement label))))
+
+(define (add-remote-link! label)
+ (if (not *purification-root-object*)
+ (set! *purification-root-object*
+ (cons *purification-root-marker* '())))
+ (set-cdr! *purification-root-object*
+ (cons (object-label-value label)
+ (cdr *purification-root-object*)))
+ unspecific)
+
+(define *purification-root-marker*
+ (intern "#[PURIFICATION-ROOT]"))
+\f
+(define (generate/remote-links n-code-blocks code-blocks-label n-sections)
+ (define-integrable max-line-width 80)
+
+ (define (sections->c-sections mul? posn n-sections)
+ (cond ((not (null? n-sections))
+ (let* ((val (number->string (car n-sections)))
+ (next (+ posn (+ 2 (string-length val)))))
+ (if (>= (1+ next) max-line-width)
+ (LAP ",\n\t\t" ,val
+ ,@(sections->c-sections true
+ (+ 16 (string-length val))
+ (cdr n-sections)))
+ (LAP ", " ,val
+ ,@(sections->c-sections mul? next (cdr n-sections))))))
+ ((or mul? (>= (+ posn 2) max-line-width))
+ (LAP "\n\t "))
+ (else
+ (LAP))))
+
+ (let ((label (generate-label))
+ (done (generate-label)))
+ (set! *purification-root-object*
+ (cons *purification-root-marker*
+ (object-label-value code-blocks-label)))
+ (declare-block-label! (continuation-code-word false) false label)
+ (use-invoke-interface! 4)
+ (LAP "*--stack_pointer = (LONG_TO_UNSIGNED_FIXNUM (1L));\n\t"
+ ,@(label-statement label)
+ "{\n\t "
+ "static const short sections []\n\t = {\t0"
+ ,@(sections->c-sections false 17 (vector->list n-sections))
+ "};\n\t "
+ "long counter = (OBJECT_DATUM (* stack_pointer));\n\t "
+ "SCHEME_OBJECT blocks, * subblock;\n\t "
+ "short section;\n\t\n\t "
+ "if (counter > " ,n-code-blocks "L)\n\t goto " ,done ";\n\t "
+ "blocks = current_block[" ,code-blocks-label "];\n\t "
+ "subblock = (OBJECT_ADDRESS (MEMORY_REF (blocks, counter)));\n\t "
+ "subblock[(OBJECT_DATUM (subblock[0]))]\n\t "
+ " = register_block[REGBLOCK_ENV];\n\t "
+ "section = sections[counter];\n\t "
+ "counter += 1;\n\t "
+ "*stack_pointer = (LONG_TO_UNSIGNED_FIXNUM (counter));\n\t "
+ "INVOKE_INTERFACE_4 (" ,code:compiler-link
+ ", ¤t_block[" ,(label->offset label) "]"
+ ",\n\t\t\t\t subblock"
+ ",\n\t\t\t\t (subblock"
+ "\n\t\t\t\t + (2 + (OBJECT_DATUM (subblock[1]))))"
+ ",\n\t\t\t\t section);\n\t}\n\t"
+ ,@(label-statement done)
+ "stack_pointer += 1;\n\t")))
+\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)
+ (define (inner name assoc)
+ (if (null? assoc)
+ (transmogrifly (cdr uuos))
+ ;; produces ((name . label) (0 . label) ... (frame-size . label) ...)
+ ;; where the (0 . label) is repeated to fill out the size required
+ ;; as specified in machin.scm
+ `((,name . ,(cdar assoc)) ; uuo-label
+ (,(caar assoc) . ; frame-size
+ ,(allocate-constant-label))
+ ,@(inner name (cdr assoc)))))
+ (if (null? uuos)
+ '()
+ ;; caar is name, cdar is alist of frame sizes
+ (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 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Interpreter Calls
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Variable cache trap handling.
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-REFERENCE (? cont)
+ (REGISTER (? extension))
+ (? safe?))
+ (let ((extension (standard-source! extension 'SCHEME_OBJECT*)))
+ (use-invoke-interface! 2)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_2 ("
+ ,(if safe?
+ code:compiler-safe-reference-trap
+ code:compiler-reference-trap)
+ ", ¤t_block[" ,(label->offset cont) "], "
+ ,extension ");\n\t")))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont)
+ (REGISTER (? extension))
+ (REGISTER (? value)))
+ (let ((value (standard-source! value 'SCHEME_OBJECT))
+ (extension (standard-source! extension 'SCHEME_OBJECT*)))
+ (use-invoke-interface! 3)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_3 ("
+ ,code:compiler-assignment-trap
+ ", ¤t_block[" ,(label->offset cont) "], "
+ ,extension
+ ", " ,value ");\n\t")))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont)
+ (REGISTER (? extension)))
+ (let ((extension (standard-source! extension 'SCHEME_OBJECT*)))
+ (use-invoke-interface! 2)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_2 (" ,code:compiler-unassigned?-trap
+ ", ¤t_block[" ,(label->offset cont) "], "
+ ,extension ");\n\t")))
+\f
+;;;; Interpreter Calls
+
+;;; All the code that follows is obsolete. It hasn't been used in a while.
+;;; It is provided in case the relevant switches are turned off, but there
+;;; is no real reason to do this. Perhaps the switches should be removed.
+
+(define-rule statement
+ (INTERPRETER-CALL:ACCESS (? cont)
+ (REGISTER (? environment))
+ (? name))
+ (lookup-call code:compiler-access cont environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:LOOKUP (? cont)
+ (REGISTER (? environment))
+ (? name)
+ (? safe?))
+ (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
+ cont
+ environment
+ name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNASSIGNED? (? cont)
+ (REGISTER (? environment))
+ (? name))
+ (lookup-call code:compiler-unassigned? cont environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNBOUND? (REGISTER (? environment)) (? name))
+ (lookup-call code:compiler-unbound? environment name))
+
+(define (lookup-call code cont environment name)
+ (let ((environment (standard-source! environment 'SCHEME_OBJECT)))
+ (use-invoke-interface! 3)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_3 (" ,code
+ ", ¤t_block[" ,(label->offset cont) "], "
+ ,environment ", "
+ "current_block[" ,(object->offset name) "]);\n\t")))
+
+(define-rule statement
+ (INTERPRETER-CALL:DEFINE (? cont)
+ (REGISTER (? environment))
+ (? name)
+ (REGISTER (? value)))
+ (assignment-call code:compiler-define cont environment name value))
+
+(define-rule statement
+ (INTERPRETER-CALL:SET! (? cont)
+ (REGISTER (? environment))
+ (? name)
+ (REGISTER (? value)))
+ (assignment-call code:compiler-set! cont environment name value))
+
+(define (assignment-call code cont environment name value)
+ (let ((environment (standard-source! environment 'SCHEME_OBJECT))
+ (value (standard-source! value 'SCHEME_OBJECT)))
+ (use-invoke-interface! 4)
+ (LAP ,@(clear-map!)
+ "INVOKE_INTERFACE_4 (" ,code
+ ", ¤t_block[" ,(label->offset cont) "], "
+ ,environment ", "
+ "current_block[" ,(object->offset name) "], " ,value ");\n\t")))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulfix.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Fixnum Rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Conversions
+
+(define (object->fixnum source target)
+ (LAP ,target " = (FIXNUM_TO_LONG (" ,source "));\n\t"))
+
+(define (address->fixnum source target)
+ (LAP ,target " = (ADDRESS_TO_LONG (" ,source "));\n\t"))
+
+(define (fixnum->object source target)
+ (LAP ,target " = (LONG_TO_FIXNUM (" ,source "));\n\t"))
+
+(define (fixnum->address source target)
+ (LAP ,target " = (LONG_TO_ADDRESS (" ,source "));\n\t"))
+
+(define-rule statement
+ ;; convert a fixnum object to a "fixnum integer"
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+ (standard-unary-conversion source 'SCHEME_OBJECT target 'LONG
+ object->fixnum))
+
+(define-rule statement
+ ;; load a fixnum constant as a "fixnum integer"
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (let ((target (standard-target! target 'LONG)))
+ (LAP ,target " = " ,(longify constant) ";\n\t")))
+
+(define-rule statement
+ ;; convert a memory address to a "fixnum integer"
+ (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
+ (standard-unary-conversion source 'SCHEME_OBJECT* target 'LONG
+ 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 'SCHEME_OBJECT target 'LONG
+ object->fixnum))
+
+(define-rule statement
+ ;; convert a "fixnum integer" to a fixnum object
+ (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
+ (standard-unary-conversion source 'LONG target 'SCHEME_OBJECT
+ fixnum->object))
+
+(define-rule statement
+ ;; convert a "fixnum integer" to a memory address
+ (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
+ (standard-unary-conversion source 'LONG target 'SCHEME_OBJECT*
+ fixnum->address))
+\f
+;; "Fixnum" in this context means a C long
+
+(define (no-overflow-branches!)
+ (set-current-branches!
+ (lambda (if-overflow)
+ if-overflow
+ (LAP))
+ (lambda (if-no-overflow)
+ (LAP "goto " ,if-no-overflow ";\n\t"))))
+
+(define (standard-overflow-branches! overflow? result)
+ (if overflow?
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP "if (!( LONG_TO_FIXNUM_P (" ,result ")))\n\t goto "
+ ,if-overflow ";\n\t"))
+ (lambda (if-not-overflow)
+ (LAP "if ( LONG_TO_FIXNUM_P (" ,result "))\n\t goto "
+ ,if-not-overflow ";\n\t"))))
+ unspecific)
+
+(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 'LONG target 'LONG
+ (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 '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?)
+ (standard-overflow-branches! overflow? tgt)
+ (cond ((back-end:= constant 0)
+ (LAP ,tgt " = " ,src ";\n\t"))
+ ((and (number? constant) (< constant 0))
+ (LAP ,tgt " = (" ,src " - " ,(- constant) "L);\n\t"))
+ (else
+ (LAP ,tgt " = (" ,src " + " ,(longify constant) ");\n\t"))))
+
+(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
+ (lambda (tgt src1 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,tgt " = ( ~ " ,src1 ");\n\t")))
+\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 'LONG source2 'LONG target 'LONG
+ (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))
+\f
+(let-syntax
+ ((binary-fixnum
+ (macro (name instr)
+ `(define-arithmetic-method ',name fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,',tgt " = (" ,',src1 ,instr ,',src2 ");\n\t"))))))
+
+ (binary-fixnum FIXNUM-AND " & ")
+ (binary-fixnum FIXNUM-OR " | ")
+ (binary-fixnum FIXNUM-XOR " ^ ")
+ (binary-fixnum FIXNUM-ANDC " & ~ "))
+
+(let-syntax
+ ((binary-fixnum
+ (macro (name instr)
+ `(define-arithmetic-method ',name fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,',tgt
+ " = (" ,instr " (" ,',src1 ", " ,',src2 "));\n\t"))))))
+
+ (binary-fixnum FIXNUM-REMAINDER "FIXNUM_REMAINDER")
+ (binary-fixnum FIXNUM-LSH "FIXNUM_LSH"))
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (standard-overflow-branches! overflow? tgt)
+ (LAP ,tgt " = (FIXNUM_QUOTIENT (" ,src1 ", " ,src2 "));\n\t")))
+
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (standard-overflow-branches! overflow? tgt)
+ (LAP ,tgt " = (" ,src1 " + " ,src2 ");\n\t")))
+
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (if (eqv? src1 src2) ;probably won't ever happen.
+ (begin
+ (no-overflow-branches!)
+ ; we don't use zero directly because we care about the tag
+ (LAP ,tgt " = (" ,src2 " - " ,src2 ");\n\t"))
+ (do-overflow-subtraction tgt src1 src2))
+ (LAP ,tgt " = (" ,src1 " - " ,src2 ");\n\t"))))
+
+(define (do-overflow-subtraction tgt src1 src2)
+ (standard-overflow-branches! true tgt)
+ (LAP ,tgt " = (" ,src1 " - " ,src2 ");\n\t"))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
+ (lambda (target src1 src2 overflow?)
+ (if (not overflow?)
+ (LAP ,target " = (" ,src1 " * " ,src2 ");\n\t")
+ (overflow-product! target src1 src2))))
+
+(define (overflow-product! target src1 src2)
+ (set-current-branches!
+ (lambda (if-overflow-label)
+ (LAP "if (multiply_with_overflow ( " ,src1 ", " ,src2 ", &" ,target
+ "))\n\t goto " ,if-overflow-label ";\n\t"))
+ (lambda (if-not-overflow-label)
+ (LAP "if (!(multiply_with_overflow ( " ,src1 ", " ,src2 ", &" ,target
+ ")))\n\t goto " ,if-not-overflow-label ";\n\t")))
+ (LAP))
+\f
+(define-rule statement
+ ;; execute binary fixnum operation with constant second arg
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (? overflow?)))
+ (standard-unary-conversion source 'LONG target 'LONG
+ (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-QUOTIENT FIXNUM-REMAINDER FIXNUM-LSH))))
+ (standard-unary-conversion source 'LONG target 'LONG
+ (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 'MINUS-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (fixnum-add-constant tgt src
+ (back-end:- 0 constant)
+ overflow?)))
+
+(define (power-of-2? value)
+ (let loop ((n value))
+ (and (> n 0)
+ (if (= n 1)
+ 0
+ (and (even? n)
+ (let ((m (loop (quotient n 2))))
+ (and m
+ (+ m 1))))))))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (cond ((back-end:= constant 0)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,tgt " = 0L;\n\t"))
+ ((back-end:= constant 1)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,tgt " = " ,src ";\n\t"))
+ ((and (number? constant)
+ (power-of-2? (abs constant)))
+ =>
+ (lambda (power-of-two)
+ (if (not overflow?)
+ (LAP ,tgt
+ ,(if (negative? constant)
+ " = (- "
+ " = ")
+ "(LEFT_SHIFT (" ,src ", " ,power-of-two
+ "))"
+ ,(if (negative? constant)
+ ")"
+ "")
+ ";\n\t")
+ (overflow-product! tgt src constant))))
+ ((not overflow?)
+ (LAP ,tgt " = (" ,src " * " ,(longify constant) ");\n\t"))
+ (else
+ (overflow-product! tgt src constant)))))
+
+(define-arithmetic-method 'MINUS-FIXNUM
+ fixnum-methods/2-args/constant*register
+ (lambda (tgt constant src overflow?)
+ (guarantee-signed-fixnum constant)
+ (if overflow?
+ (do-overflow-subtraction tgt constant src)
+ (LAP ,tgt " = (" ,constant " - " ,src ");\n\t"))))
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (cond ((back-end:= constant 0)
+ (error "fixnum-quotient constant division by zero."))
+ ((back-end:= constant 1)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,tgt " = " ,src ";\n\t"))
+ ((back-end:= constant -1)
+ (standard-overflow-branches! overflow? tgt)
+ (LAP ,tgt " = - " ,src ";\n\t"))
+ ((and (number? constant)
+ (power-of-2? (abs constant)))
+ =>
+ (lambda (power-of-two)
+ (if overflow?
+ (no-overflow-branches!))
+ (LAP ,tgt
+ ,(if (negative? constant)
+ " = (- "
+ " = ")
+ "((" ,src " < 0) ? (RIGHT_SHIFT ((" ,src " + "
+ ,(-1+ (abs constant)) "), " ,power-of-two "))"
+ " : (RIGHT_SHIFT (" ,src " ," ,power-of-two ")))"
+ ,(if (negative? constant)
+ ")"
+ "")
+ ";\n\t")))
+ (else
+ (standard-overflow-branches! overflow? tgt)
+ (LAP ,tgt " = (FIXNUM_QUOTIENT (" ,src ", " ,(longify constant)
+ "));\n\t")))))
+
+(define-arithmetic-method 'FIXNUM-REMAINDER
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src s-constant overflow?)
+ (let ((constant (abs s-constant)))
+ (if overflow? (no-overflow-branches!))
+ (cond ((back-end:= constant 0)
+ (error "fixnum-remainder constant division by zero."))
+ ((back-end:= constant 1)
+ (LAP ,tgt " = 0;\n\t"))
+ ((and (number? constant)
+ (power-of-2? constant))
+ =>
+ (lambda (power-of-two)
+ (LAP "{\n\t long temp = (" ,src " & " ,(-1+ constant)
+ "L);\n\t "
+ ,tgt " = ((" ,src " >= 0) ? temp : ((temp == 0) ? 0"
+ " : (temp | (LEFT_SHIFT (-1L, " ,power-of-two
+ ")))));\n\t}\n\t")))
+ (else
+ (LAP ,tgt " = (FIXNUM_REMAINDER (" ,src ", " ,(longify constant)
+ "));\n\t"))))))
+
+(define-arithmetic-method 'FIXNUM-LSH
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (cond (overflow?
+ (error "fixnum-lsh overflow what??"))
+ ((back-end:= constant 0)
+ (LAP ,tgt " = " ,src ";\n\t"))
+ ((not (number? constant))
+ (LAP ,tgt " = (FIXNUM_LSH (" ,src ", " ,constant "));\n\t"))
+ ((positive? constant)
+ (LAP ,tgt " = (LEFT_SHIFT (" ,src ", " ,constant "));\n\t"))
+ (else
+ (LAP "{\n\t unsigned long temp = ((unsigned long) " ,src ");\n\t "
+ ,tgt " = ((long) (RIGHT_SHIFT_UNSIGNED (temp, " ,(- constant)
+ ")));\n\t}\n\t")))))
+
+(let-syntax
+ ((binary-fixnum
+ (macro (name instr)
+ `(define-arithmetic-method ',name
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src1 constant overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,',tgt " = (" ,',src1 ,instr ,',(longify constant) ");\n\t"))))))
+
+ (binary-fixnum FIXNUM-AND " & ")
+ (binary-fixnum FIXNUM-OR " | ")
+ (binary-fixnum FIXNUM-XOR " ^ ")
+ (binary-fixnum FIXNUM-ANDC " & ~ "))
+
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args/constant*register
+ (lambda (tgt constant src2 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,tgt " = (" ,(longify constant) " & ~ " ,src2 ");\n\t")))
+\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 (case predicate
+ ((ZERO-FIXNUM?) " == ")
+ ((NEGATIVE-FIXNUM?) " < ")
+ ((POSITIVE-FIXNUM?) " > ")
+ (else (error "unknown fixnum predicate" predicate)))
+ (standard-source! source 'LONG)
+ "0"))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (compare (fixnum-pred-2->cc predicate)
+ (standard-source! source1 'LONG)
+ (standard-source! source2 'LONG)))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (compare (fixnum-pred-2->cc predicate)
+ (standard-source! source 'LONG)
+ (longify constant)))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (REGISTER (? source)))
+ (compare (fixnum-pred-2->cc predicate)
+ (longify constant)
+ (standard-source! source 'LONG)))
+
+(define (fixnum-pred-2->cc predicate)
+ (case predicate
+ ((EQUAL-FIXNUM?) " == ")
+ ((LESS-THAN-FIXNUM?) " < ")
+ ((GREATER-THAN-FIXNUM?) " > ")
+ (else
+ (error "unknown fixnum predicate" predicate))))
+
+(define (longify constant)
+ (if (number? constant)
+ (string-append (number->string constant)
+ "L")
+ constant))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulflo.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Flonum rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Flonum Arithmetic
+
+(define-rule statement
+ ;; convert a floating-point number to a flonum object
+ (ASSIGN (REGISTER (? target))
+ (FLOAT->OBJECT (REGISTER (? source))))
+ (let ((source (standard-source! source 'double)))
+ (let ((target (standard-target! target 'SCHEME_OBJECT)))
+ (LAP "INLINE_DOUBLE_TO_FLONUM (" ,source ", " ,target ");\n\t"))))
+
+(define-rule statement
+ ;; convert a flonum object to a floating-point number
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
+ (let ((source (standard-source! source 'SCHEME_OBJECT)))
+ (let ((target (standard-target! target 'double)))
+ (LAP ,target " = (FLONUM_TO_DOUBLE (" ,source "));\n\t"))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
+ overflow? ;ignore
+ (let ((source (standard-source! source 'double)))
+ ((flonum-1-arg/operator operation)
+ (standard-target! target 'double)
+ 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 ,target " = ((" ,source " >= 0.) ? " ,source " : (-" ,source
+ "));\n\t")))
+
+(define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg
+ (lambda (target source)
+ (LAP ,target " = (- " ,source ");\n\t")))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ overflow? ;ignore
+ (let ((source1 (standard-source! source1 'double))
+ (source2 (standard-source! source2 'double)))
+ ((flonum-2-args/operator operation)
+ (standard-target! target 'double)
+ source1
+ source2)))
+\f
+(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 ,',target " = (" ,',source1 ,opcode ,',source2
+ ");\n\t"))))))
+ (define-flonum-operation flonum-add " + ")
+ (define-flonum-operation flonum-subtract " - ")
+ (define-flonum-operation flonum-multiply " * ")
+ (define-flonum-operation flonum-divide " / "))
+
+;;;; Flonum Predicates
+
+(define-rule predicate
+ (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ (compare (case predicate
+ ((FLONUM-ZERO?) " == ")
+ ((FLONUM-NEGATIVE?) " < ")
+ ((FLONUM-POSITIVE?) " > ")
+ (else (error "unknown flonum predicate" predicate)))
+ (standard-source! source 'double)
+ "0.0"))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (compare (case predicate
+ ((FLONUM-EQUAL?) " == ")
+ ((FLONUM-LESS?) " < ")
+ ((FLONUM-GREATER?) " > ")
+ (else (error "unknown flonum predicate" predicate)))
+ (standard-source! source1 'double)
+ (standard-source! source2 'double)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulrew.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rewrite Rules
+;;; 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-constant 0)))
+
+(define-rule rewriting
+ (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-constant 0)))
+
+(define-rule rewriting
+ (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-register 0)))
+
+(define (rtl:immediate-zero-constant? expression)
+ (cond ((rtl:constant? expression)
+ (let ((value (rtl:constant-value expression)))
+ (and (non-pointer-object? value)
+ (zero? (object-type value))
+ (zero? (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)))
+
+;;; Fixnums
+
+(define-rule rewriting
+ (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-fixnum? source))
+ (rtl:make-object->fixnum source))
+
+(define (rtl:constant-fixnum? expression)
+ (and (rtl:constant? expression)
+ (fix:fixnum? (rtl:constant-value expression))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/assmd.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+$MC68020-Header: assmd.scm,v 1.36 89/08/28 18:33:33 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Assembler Machine Dependencies
+
+(declare (usual-integrations))
+\f
+(let-syntax ((ucode-type (macro (name) `',(microcode-type name))))
+
+(define-integrable maximum-padding-length
+ ;; Instruction length is always a multiple of 32 bits
+ ;; Would 0 work here?
+ 32)
+
+(define padding-string
+ ;; Pad with `UNIMP' instructions
+ (unsigned-integer->bit-string maximum-padding-length
+ #b00000000000000000000000000000000 ))
+
+(define-integrable block-offset-width
+ ;; Block offsets are always 16 bit words
+ 16)
+
+(define-integrable maximum-block-offset
+ ;; PC always aligned on longword boundary. Use the extra bit.
+ (- (expt 2 (1+ block-offset-width)) 4))
+
+(define (block-offset->bit-string offset start?)
+ (unsigned-integer->bit-string block-offset-width
+ (+ (quotient offset 2)
+ (if start? 0 1))))
+
+(define (make-nmv-header n)
+ (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
+ nmv-type-string))
+
+(define nmv-type-string
+ (unsigned-integer->bit-string scheme-type-width
+ (ucode-type manifest-nm-vector)))
+
+(define (object->bit-string object)
+ (bit-string-append
+ (unsigned-integer->bit-string scheme-datum-width
+ (careful-object-datum object))
+ (unsigned-integer->bit-string scheme-type-width (object-type object))))
+
+;;; Machine dependent instruction order
+
+(define (instruction-insert! bits block position receiver)
+ (let ((l (bit-string-length bits)))
+ (if (eq? endianness 'LITTLE)
+ (begin
+ (bit-substring-move-right! bits 0 l block position)
+ (receiver (+ position l)))
+ (let ((new-position (- position l)))
+ (bit-substring-move-right! bits 0 l block new-position)
+ (receiver new-position)))))
+
+(define-integrable instruction-initial-position bit-string-length)
+(define-integrable instruction-append bit-string-append-reversed)
+
+;;; end let-syntax
+)
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/cf.h-sparc,v 1.1 1993/06/08 06:11:57 gjr Exp $
+
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#define PROC_TYPE_UNKNOWN 0
+#define PROC_TYPE_68000 1
+#define PROC_TYPE_68020 2
+#define PROC_TYPE_HPPA 3 /* HP Precision Architecture */
+#define PROC_TYPE_VAX 4
+#define PROC_TYPE_MIPS 5
+#define PROC_TYPE_NS32K 6
+#define PROC_TYPE_HCX 7 /* Harris HCX */
+#define PROC_TYPE_IBM032 8 /* IBM RT */
+#define PROC_TYPE_SPARC 9
+#define PROC_TYPE_I386 10
+#define PROC_TYPE_ALPHA 11
+#define PROC_TYPE_POWER 12 /* IBM RS6000 and PowerPC */
+
+/* Define this macro to use a non-standard compiler.
+ It must be defined before including the m/ and s/ files because
+ they may be conditionalized on it. */
+
+#define ALTERNATE_CC gcc-2.3.3
+
+/* Define this macro to use a non-standard assembler. */
+/* #define ALTERNATE_AS gashp */
+
+#include "s.h"
+#include "m.h"
+
+#ifndef PROC_TYPE
+#define PROC_TYPE PROC_TYPE_UNKNOWN
+#endif
+
+/* Define HAVE_X_WINDOWS if you want to use the X window system. */
+#define HAVE_X_WINDOWS
+
+/* Define HAVE_STARBASE_GRAPHICS if you want Starbase graphics support.
+ This is specific to HP-UX. */
+/* #define HAVE_STARBASE_GRAPHICS */
+/* #define STARBASE_DEVICE_DRIVERS -ldd300h -ldd98700 -ldd98710 -ldd98556 */
+
+/* Some compilation options:
+ -DDISABLE_HISTORY turns off history recording mechanism */
+#define C_SWITCH_FEATURES
+
+/* The following two switches are mutually exclusive for most C compilers.
+ An exception is the GNU C compiler. */
+
+/* If defined, this prevents the C compiler from running its optimizer. */
+#define SUPPRESS_C_OPTIMIZER
+
+/* If defined, this prevents the C compiler from
+ generating debugging information. */
+#define SUPPRESS_C_DEBUGGING
--- /dev/null
+/* #define DEBUG_INTERFACE */ /* -*-Midas-*- */
+ !###
+ !### $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/cmpaux-sparc.m4,v 1.1 1993/06/08 06:11:57 gjr Exp $
+ !###
+ !### Copyright (c) 1989-1992 Massachusetts Institute of Technology
+ !###
+ !### This material was developed by the Scheme project at the
+ !### Massachusetts Institute of Technology, Department of
+ !### Electrical Engineering and Computer Science. Permission to
+ !### copy this software, to redistribute it, and to use it for any
+ !### purpose is granted, subject to the following restrictions and
+ !### understandings.
+ !###
+ !### 1. Any copy made of this software must include this copyright
+ !### notice in full.
+ !###
+ !### 2. Users of this software agree to make their best efforts (a)
+ !### to return to the MIT Scheme project any improvements or
+ !### extensions that they make, so that these may be included in
+ !### future releases; and (b) to inform MIT of noteworthy uses of
+ !### this software.
+ !###
+ !### 3. All materials developed as a consequence of the use of this
+ !### software shall duly acknowledge such use, in accordance with
+ !### the usual standards of acknowledging credit in academic
+ !### research.
+ !###
+ !### 4. MIT has made no warrantee or representation that the
+ !### operation of this software will be error-free, and MIT is
+ !### under no obligation to provide any services, by way of
+ !### maintenance, update, or otherwise.
+ !###
+ !### 5. In conjunction with products arising from the use of this
+ !### material, there shall be no use of the name of the
+ !### Massachusetts Institute of Technology nor of any adaptation
+ !### thereof in any advertising, promotional, or sales literature
+ !### without prior written consent from MIT in each case.
+ !###
+
+ !#### SPARC Architecture assembly language part of the compiled
+ !#### code interface. See cmpint.txt, cmpint.c, cmpint-mips.h, and
+ !#### cmpgc.h for more documentation.
+ !####
+ !#### NOTE:
+ !#### Assumptions:
+ !####
+ !#### 1) All registers (except double floating point registers) and
+ !#### stack locations hold a C long object.
+ !####
+ !#### 2) The C compiler divides registers into four categories:
+ !#### in: (%i7-%i0 or %r31-%r24) incoming parameters
+ !#### note: %fp is in this group
+ !#### note: %i7 holds the C return address, don't bash this.
+ !####
+ !#### out: (%o7-%o0 or %r15-%r8) outgoing parameters
+ !#### note: %sp is in this group
+ !####
+ !#### locals: (%l7-%l0 or %r23-%r16)
+ !####
+ !#### globals: (%g7-%g0 or %r7-%r0), reserved, essentially useless
+ !####
+ !#### The ins and locals are callee save through the standard SPARC save
+ !#### and restore instructions. This has the added effect of cleaning
+ !#### up the stack and frame pointers correctly. Globals are callee save.
+ !#### Note that save and restore also pose as simulataneous add
+ !#### instructions. This comes in handy for allocating the stack frame.
+ !####
+ !#### 3) On SPARC the floating point registers are totally ungoverned.
+ !#### The de-facto standard is caller save.
+
+
+ !#### Compiled Scheme code uses the following register convention.
+ !#### - g0 is the 0 constant (hardwired)
+ !#### - g1 is the designated temporary (scheme available)
+ !#### - g2-g4 are available for globals (scheme available)
+ !#### - g5-g7 are off limits super globals. (don't touch!)
+ !#### < Start of C callee saves >
+ !#### - l0 is the return value register. (scheme available)
+ !#### - l1 contains the Scheme stack pointer. (scheme available)
+ !#### - l2 contains a cached version of MemTop. (scheme available)
+ !#### - l3 contains the Scheme free pointer. (scheme available)
+ !#### - l4 contains the address of scheme_to_interface. (scheme available)
+ !#### - l5 contains the dynamic link when needed. (scheme available)
+ !#### - l6 contains the closure free pointer. (scheme available)
+ !#### - l7 is leftover (used for tramp index) (scheme available)
+ !#### - i0 is the C return value / first parameter (scheme available)
+ !#### - i1 contains the address mask for machine pointers. (scheme available)
+ !#### - i2 contains a pointer to the Scheme interpreter's (scheme available)
+ !#### "register" block. This block contains the compiler's
+ !#### copy of MemTop, the interpreter's registers (val, env,
+ !#### exp, etc), temporary locations for compiled code.
+ !#### - i3 contains the top 6 address bits for heap pointers. (scheme available)
+ !#### - i4 contains the closure hook. (scheme available)
+ !#### - i5 is leftover. (scheme available)
+ !#### - i6 is the C frame pointer, alternatively the old C sp.(don't touch!)
+ !#### - i7 is the C return address. (don't touch!)
+ !#### < End of C callee saves >
+ !#### - o7 is the target of call instructions, ie next pc. (scheme available)
+ !#### - o6 is the current C stack pointer. (scheme available)
+ !#### - o5-o1 are outgoing parameters to the C world. (scheme available)
+ !#### - o0 is an outgoing parameter to the C world, and the return value
+ !#### from there (scheme available)
+ !####
+
+ !# .verstamp 1 31
+
+define(value, l0)
+define(stack, l1)
+define(C_arg1, o0)
+define(C_arg2, o1)
+define(C_arg3, o2)
+define(C_arg4, o3)
+define(utility_index, o5)
+
+define(memtop, l2)
+define(free, l3)
+define(s_to_i, l4)
+define(dynlink, l5)
+
+define(closure_free, l6)
+define(addr_mask, i1)
+define(registers, i2)
+define(heap_bits, i3)
+define(closure_reg, i4)
+
+ .global _Free
+ .global _Registers
+ .global _Ext_Stack_Pointer
+
+ .text
+ .align 4
+
+
+ !# Argument (in $C_arg1) is a compiled Scheme entry point
+ !# but save C registers first
+ .align 4
+ .global _C_to_interface
+ .proc 020
+_C_to_interface:
+ save %sp,-104,%sp
+
+ !# Make space for interface return structs and stick a pointer to
+ !# on the stack. SPARC C calling conventions require this.
+
+ add %fp, -24, %o0
+ st %o0,[%sp+64]
+
+ !# Now stick the right interpreter registers into the right machine
+ !# registers.
+
+ sethi %hi(_Free), %g1
+ ld [%g1+%lo(_Free)], %heap_bits
+ sethi %hi(0xfc000000), %addr_mask
+ sethi %hi(_Registers), %g1
+ or %g1, %lo(_Registers), %registers
+ and %heap_bits, %addr_mask, %heap_bits
+ xnor %g0, %addr_mask, %addr_mask
+
+ .align 4
+ .global _interface_to_scheme
+_interface_to_scheme:
+
+ sethi %hi(_Free), %g1
+ ld [%g1+%lo(_Free)], %free
+ sethi %hi(_Ext_Stack_Pointer), %g1
+ ld [%g1+%lo(_Ext_Stack_Pointer)], %stack
+
+ ld [%registers + 36],%closure_free
+ ld [%registers + 8],%value
+ ld [%registers],%memtop
+
+ and %value,%addr_mask,%dynlink
+ or %dynlink,%heap_bits,%dynlink
+ jmpl %i0 + 0, %o7
+ add %o7,264,%s_to_i
+
+!# Don't rearrange the following procedures. The compiler backend knows their offsets
+!# from scheme_to_interface and uses this knowledge to jump to them.
+
+ .align 4
+ .global _cons_multi_closure
+ !# arg1 -> linkage data start address
+ !# arg2 -> number of entries
+ !# arg3 -> contains contents of %free
+ !# %s_to_1 -256
+ !# C_arg1 points to a manifest closure header word, followed by
+ !# nentries two-word structures, followed by the actual
+ !# instructions to return to.
+ !# The first word of each descriptor is the format+gc-offset word of
+ !# the corresponding entry point of the generated closure.
+ !# The second word is the offset from the entry address to the real
+ !# code of the closure.
+_cons_multi_closure:
+ save %sp, -96, %sp
+ add %i0, 0, %l0
+
+ !# Stuff the tag word and length into the beginning of the multi-closure
+ !# also write in the number of entries word.
+ ld [%l0], %g1
+ st %g1, [%i2]
+ add %l0, 4, %l0
+
+ sll %i1, 16, %g1
+ st %g1, [%i2 + 4]
+
+ !# Setup a template for the Addi part of each entry
+ sethi %hi(0x82006008), %l1
+ add %lo(0x82006008), %l1, %l1
+
+ !# Calcualate the first offset to the closed var.
+ add %i1, -1, %l2
+ umul %l2, 16, %l2
+
+ !# Copy free and bump it up two words
+ add %i2, 8, %l3
+
+cmc_l2:
+ !# Copy the format+gc-offset word into the start of the entry
+ ld [%l0], %g1
+ st %g1, [%l3]
+
+ !# Construct the sethi(target) part of the entry
+ ld [%l0+4], %g1
+ add %i0, %g1, %g1
+ srl %g1, 10, %l4
+ sethi %hi(0x03000000), %l5
+ or %l4, %l5, %l5
+ st %l5, [%l3+4]
+
+ !# Construct the jmpl(lo(target)) part of the entry
+ and %g1, 0x3ff, %l4
+ sethi %hi(0x83c06000), %l5
+ or %l4, %l5, %l5
+ st %l5, [%l3+8]
+
+ !# Construct the addi offset-to-data part of the entry
+ add %l2, %l1, %l5
+ st %l5, [%l3+12]
+
+ !# Flush the instruction cache
+ iflush %l3 + 4
+ iflush %l3 + 8
+ iflush %l3 + 12
+
+ !# Bump to the next entry, next set of data
+
+ add %l3, 16, %l3
+ add %l0, 8, %l0
+ subcc %l2, 16, %l2
+ bge cmc_l2
+ nop
+
+ add %l0, 0, %g1
+ jmpl %g1, %g0
+ restore
+
+ .align 4
+ .global _cons_closure
+ !# arg1 -> return address
+ !# arg2 -> delta from return address
+ !# arg3 -> closure size (in bytes)
+ !# arg4 -> using as an extra temp
+ !# s_to_i -108
+_cons_closure:
+ ld [%C_arg1], %g1
+ st %g1, [%free]
+ ld [%C_arg1 + 4], %g1
+ st %g1, [%free + 4]
+ add %g0, %g0, %C_arg4
+ add %C_arg2, %C_arg1, %C_arg2
+ sethi %hi(0x03000000), %C_arg4
+ srl %C_arg2, 10, %g1
+ add %g1, %C_arg4, %C_arg4
+ st %C_arg4, [%free + 8]
+ sethi %hi(0x83c06000), %C_arg4
+ and 0x3ff, %C_arg2, %g1
+ add %g1, %C_arg4, %C_arg4
+ st %C_arg4, [%free + 12]
+ sethi %hi(0x82006008), %C_arg4
+ add %lo(0x82006008), %C_arg4, %C_arg4
+ st %C_arg4, [%free + 16]
+ iflush %free + 8
+ iflush %free + 12
+ iflush %free + 16
+ add %free, 8, %C_arg2
+ add %C_arg3, %free, %free
+ add %C_arg1, 8, %C_arg1
+ jmpl %C_arg1, %g0
+ nop
+
+ .align 4
+ .global _trampoline_to_interface
+ !# s_to_i - 8
+_trampoline_to_interface:
+ add %C_arg1, -4, %C_arg1
+
+ .align 4
+ .global _link_to_interface
+ !# s_to_i - 4
+_link_to_interface:
+ add %C_arg1, 12, %C_arg1
+
+ .align 4
+ .global _scheme_to_interface
+ .proc 020
+_scheme_to_interface:
+ st %value,[%registers + 8]
+ st %closure_free,[%registers + 36]
+
+ sethi %hi(_utility_table), %g1
+ or %g1, %lo(_utility_table), %g1 !# Find table
+ add %g1,%utility_index,%g1 !# Address of entry
+ ld [%g1],%l7 !# l7 <- Entry
+ nop
+ sethi %hi(_Ext_Stack_Pointer), %g1
+ st %stack,[%g1+%lo(_Ext_Stack_Pointer)] !# Save Scheme stack pointer
+ nop
+ sethi %hi(_Free), %g1
+ st %free,[%g1+%lo(_Free)] !# Save Free
+ nop
+ jmpl %l7 + 0, %o7 !# Off to interface code
+ nop
+ unimp 8
+ ld [%o0 + 4],%i0 !# Get dispatch address
+ ld [%o0],%C_arg1 !# Arg1 <- value component
+ jmpl %C_arg1,%o7 !# Redispatch ...
+ nop !# Branch delay
+
+ .align 4
+ .global _interface_to_C
+ .proc 020
+_interface_to_C:
+ add %i0,%g0,%C_arg1 !# Return value to C
+ ret !# Return to the C universe
+ restore !# Restore callee save regs
+
+ .align 4
+ .global _flushrange
+ .proc 020
+_flushrange:
+ save %sp,-96,%sp
+ !# arg1: address base, arg2: byte count
+ add %g0, %g0, %l0
+flush_l:
+ iflush %i0 + %l0
+ add 4, %l0, %l0
+ subcc %l0,%i1,%g0
+ bl flush_l !# Continue if address < address + count
+ nop
+ nop !# flush pipeline
+ nop
+ nop
+ nop
+ nop
+ ret !# Return to caller
+ restore !# Restore callee save regs
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/cmpint-sparc.h,v 1.1 1993/06/08 06:11:57 gjr Exp $
+
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/*
+ *
+ * Compiled code interface macros.
+ *
+ * See cmpint.txt for a description of these fields.
+ *
+ * Specialized for the MIPS R2000/R3000
+ */
+
+#ifndef CMPINT2_H_INCLUDED
+#define CMPINT2_H_INCLUDED
+
+#define ICACHEFLUSH(addr, nbytes) flushrange ((addr), (nbytes))
+
+#define COMPILER_NONE_TYPE 0
+#define COMPILER_MC68020_TYPE 1
+#define COMPILER_VAX_TYPE 2
+#define COMPILER_SPECTRUM_TYPE 3
+#define COMPILER_OLD_MIPS_TYPE 4
+#define COMPILER_MC68040_TYPE 5
+#define COMPILER_SPARC_TYPE 6
+#define COMPILER_RS6000_TYPE 7
+#define COMPILER_MC88K_TYPE 8
+#define COMPILER_I386_TYPE 9
+#define COMPILER_ALPHA_TYPE 10
+#define COMPILER_MIPS_TYPE 11
+\f
+/* Machine parameters to be set by the user. */
+
+/* Processor type. Choose a number from the above list, or allocate your own. */
+
+#define COMPILER_PROCESSOR_TYPE COMPILER_SPARC_TYPE
+
+/* Size (in long words) of the contents of a floating point register if
+ different from a double. For example, an MC68881 saves registers
+ in 96 bit (3 longword) blocks.
+ Default is fine for MIPS.
+ define COMPILER_TEMP_SIZE 3
+*/
+
+/* Descriptor size.
+ This is the size of the offset field, and of the format field.
+ This definition probably does not need to be changed.
+ */
+
+typedef unsigned short format_word;
+
+/* PC alignment constraint.
+ Change PC_ZERO_BITS to be how many low order bits of the pc are
+ guaranteed to be 0 always because of PC alignment constraints.
+*/
+
+#define PC_ZERO_BITS 2
+\f
+/* Utilities for manipulating absolute subroutine calls.
+ On the SPARC this is done with:
+ CALL destination
+
+ The low 30 bits of the instruction form the address. This will
+ automatically be shifted over 2 bits to adjust for alignment.
+ */
+
+#define EXTRACT_FROM_JAL_INSTR(target, address) \
+{ \
+ unsigned long * addr = ((unsigned long *) (address)); \
+ unsigned long jal_instr = (*addr); \
+ (target) = \
+ ((SCHEME_OBJECT) \
+ ((((long) (address)) & 0x3FFFFFFF))); \
+}
+
+#define CALL_OP (0x1 << 30)
+#define CALL_INSTR(dest) (CALL_OP | (dest >> 2))
+
+#define STORE_JAL_INSTR(entry_point, address) \
+{ \
+ unsigned long ep = ((unsigned long) (entry_point)); \
+ unsigned long * addr = ((unsigned long *) (address)); \
+ if ((((long) addr) & 0x3) != 0) \
+ { \
+ fprintf (stderr, \
+ "\nSTORE_JAL_INSTR: Bad addr in CALL 0x%x, 0x%x\n", \
+ addr, ep); \
+ } \
+ (*addr) = CALL_INSTR (ep); \
+}
+\f
+/* Compiled Code Register Conventions */
+/* This must match the compiler and cmpaux-sparc.s */
+
+#define COMP_REG_TEMPORARY 1
+#define COMP_REG_RETURN 16
+#define COMP_REG_STACK 17
+#define COMP_REG_C_ARG_1 8
+#define COMP_REG_C_ARG_2 9
+#define COMP_REG_C_ARG_3 10
+#define COMP_REG_C_ARG_4 11
+#define COMP_REG_MEMTOP 18
+#define COMP_REG_FREE 19
+#define COMP_REG_SCHEME_TO_INTERFACE 20
+#define COMP_REG_DYNAMIC_LINK 21
+#define COMP_REG_TRAMP_INDEX 13
+
+#define COMP_REG_CLOSURE_FREE 22
+#define COMP_REG_ADDRESS_MASK 25
+#define COMP_REG_REGISTERS 26
+#define COMP_REG_QUAD_MASK 27
+#define COMP_REG_CLOSURE_HOOK 28
+
+#define COMP_REG_KERNEL_RESERVED_1 2
+#define COMP_REG_KERNEL_RESERVED_2 3
+#define COMP_REG_KERNEL_RESERVED_3 4
+#define COMP_REG_C_GLOBALS
+#define COMP_REG_C_STACK 30
+#define COMP_REG_LINKAGE 31
+
+/* Interrupt/GC polling. */
+
+/* Skip over this many BYTES to bypass the GC check code (ordinary
+procedures and continuations differ from closures) */
+
+#define ENTRY_SKIPPED_CHECK_OFFSET 12
+#define CLOSURE_SKIPPED_CHECK_OFFSET 40
+
+/* The length of the GC recovery code that precedes an entry.
+ On the SPARC a "addi, jalr, addi" instruction sequence.
+ */
+
+#define ENTRY_PREFIX_LENGTH 12
+
+/*
+ The instructions for a normal entry should be something like
+
+ ADDICC $at,$FREE,$MEMTOP
+ BGE interrupt
+ LD $MEMTOP,REG_BLOCK
+
+ For a closure
+
+ LUI $at,FROB(TC_CLOSURE) ; temp <- closure tag
+ XOR $1,$1,$at ; 1 <- tagged value
+ ADDI $SP,$SP,-4 ; push closure
+ ST $1,0($SP)
+ ADDICC $at,$FREE,$MEMTOP
+ BGE interrupt
+ LD $MEMTOP,REG_BLOCK
+*/
+
+/* A NOP on machines where instructions are longword-aligned. */
+
+#define ADJUST_CLOSURE_AT_CALL(entry_point, location) \
+do { \
+} while (0)
+
+/* Compiled closures */
+
+/* Manifest closure entry block size.
+ Size in bytes of a compiled closure's header excluding the
+ TC_MANIFEST_CLOSURE header.
+
+ On the SPARC this is 2 format_words for the format word and gc offset
+ words, and 12 more bytes for 3 instructions.
+
+ The three instructions are:
+
+ SETHI %HI(TARGET), GLOBAL_TEMP
+ JMPL [GLOBAL_TEMP + %LO(TARGET)], GLOBAL_TEMP
+ ADDI 8,GLOBAL_TEMP,GLOBAL_TEMP
+ */
+
+#define SETHI_GLOBAL_TEMP_TEMPLATE 0x03000000
+#define NOP_INSTRUCTION 0x01000000
+#define JMPL_TEMPLATE 0x81c06000
+#define CLOSURE_JMPL_TEMPLATE 0x83c06000
+
+#define COMPILED_CLOSURE_ENTRY_SIZE 16
+
+/* Manifest closure entry destructuring.
+
+ Given the entry point of a closure, extract the `real entry point'
+ (the address of the real code of the procedure, ie. one indirection)
+ from the closure.
+
+ On the SPARC we have to extract from a SETHI/JMPL_OFFSET sequence.
+
+*/
+
+#define EXTRACT_CLOSURE_ENTRY_ADDRESS(extracted_ep, clos_addr) do \
+{ \
+ unsigned long * addr = ((unsigned long*)(clos_addr)); \
+ unsigned long sethi_instr = addr[0]; \
+ unsigned long jmpl_instr = addr[1]; \
+ (extracted_ep) = \
+ ((SCHEME_OBJECT) \
+ (((sethi_instr & 0x3fffff) << 10) | (jmpl_instr & 0x3ff))); \
+} while (0)
+
+/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
+ Given a closure's entry point and a code entry point, store the
+ code entry point in the closure.
+ */
+
+/* The following is a SPARC ADDI 8,G1,G1 */
+#define CLOSURE_BUMP_LINKAGE_TO_DATA_INSTR 0x82006008
+
+#define STORE_CLOSURE_ENTRY_ADDRESS(ep_to_store, clos_addr) do \
+{ \
+ unsigned long * addr = (unsigned long *)(clos_addr); \
+ unsigned long target = (unsigned long)(ep_to_store); \
+ addr[0] = (addr[0] & SETHI_GLOBAL_TEMP_TEMPLATE) | (target >> 10); \
+ addr[1] = (addr[1] & CLOSURE_JMPL_TEMPLATE) | (target & 0x000003ff); \
+ addr[2] = CLOSURE_BUMP_LINKAGE_TO_DATA_INSTR; \
+} while (0)
+\f
+/* Trampolines
+
+ On the SPARC, here's a picture of a trampoline (offset in bytes from
+ entry point)
+
+ -12: MANIFEST vector header
+ - 8: NON_MARKED header
+ - 4: Format word
+ - 2: 0x6 (GC Offset to start of block from .+2)
+ Note the encoding -- divided by 2, low bit for
+ extended distances (see OFFSET_WORD_TO_BYTE_OFFSET)
+ 0: ADDI TEMP,SCHEME_TO_INTERFACE,MAGIC_CONSTANT
+ 4: JALR LINKAGE,TEMP
+ 8: ADDI TRAMP_INDEX,0,index
+ 12: trampoline dependent storage (0 - 3 longwords)
+
+ TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine
+ dependent portion of a trampoline, including the GC and format
+ headers. The code in the trampoline must store an index (used to
+ determine which C SCHEME_UTILITY procedure to invoke) in a
+ register, jump to "scheme_to_interface" and leave the address of
+ the storage following the code in a standard location.
+
+ TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a
+ trampoline when given the address of the word containing
+ the manifest vector header. According to the above picture,
+ it would add 12 bytes to its argument.
+
+ TRAMPOLINE_STORAGE takes the address of the first instruction in a
+ trampoline (not the start of the trampoline block) and returns the
+ address of the first storage word in the trampoline.
+
+ STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in
+ the trampoline and stores the instructions. It also receives the
+ index of the C SCHEME_UTILITY to be invoked.
+*/
+
+#define TRAMPOLINE_ENTRY_SIZE 5
+#define TRAMPOLINE_BLOCK_TO_ENTRY 3
+
+#define TRAMPOLINE_ENTRY_POINT(tramp_block) \
+ (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
+
+#define TRAMPOLINE_STORAGE(tramp_entry) \
+ ((((SCHEME_OBJECT *)(tramp_entry)) + 3))
+
+#define SPECIAL_OPCODE 000
+#define ADDI_OPCODE 010
+
+#define OP(OPCODE) (OPCODE << 18)
+#define SPECIAL_OP OP(SPECIAL_OPCODE)
+#define ADDI_OP OP(ADDI_OPCODE)
+
+#define JALR_TEMPLATE 0x81c02000
+#define JALR_SRC(n) ((n & 0x1F) << 14)
+#define JALR_DST(n) ((n & 0x1F) << 25)
+#define JALR(d,s) (JALR_TEMPLATE|JALR_SRC(s)|JALR_DST(d))
+
+#define ADDI_TEMPLATE 0x80002000
+#define ADDI_SRC(n) ((n & 0x1F) << 14)
+#define ADDI_DST(n) ((n & 0x1F) << 25)
+#define ADDI_IMMED(n) (n & 0x1FFF)
+#define ADDI(d,s,imm) (ADDI_TEMPLATE|ADDI_DST(d)|ADDI_SRC(s)|ADDI_IMMED(imm))
+
+#define STORE_TRAMPOLINE_ENTRY(entry_address, index) \
+{ unsigned long *PC; \
+ PC = ((unsigned long *) (entry_address)); \
+ *PC++ = ADDI(COMP_REG_TEMPORARY, COMP_REG_SCHEME_TO_INTERFACE, -8); \
+ *PC++ = JALR(COMP_REG_C_ARG_1, COMP_REG_TEMPORARY); \
+ *PC = ADDI(COMP_REG_TRAMP_INDEX, 0, (4*index)); \
+ /* assumes index fits in 13 bits */ \
+}
+\f
+/* Execute cache entries.
+
+ Execute cache entry size size in longwords. The cache itself
+ contains both the number of arguments provided by the caller and
+ code to jump to the destination address. Before linkage, the cache
+ contains the callee's name instead of the jump code.
+
+ On SPARC: 3 instructions, the last being a NO-OP (SETHI with
+ constant 0, destination 0)
+ */
+
+#define EXECUTE_CACHE_ENTRY_SIZE 3
+
+/* Execute cache destructuring. */
+
+/* Given a target location and the address of the first word of an
+ execute cache entry, extract from the cache cell the number of
+ arguments supplied by the caller and store it in target. */
+
+/* For the SPARC (big endian), addresses in bytes from the start of
+ the cache:
+
+ Before linking
+ +0: TC_SYMBOL || symbol address
+ +4: TC_FIXNUM || 0
+ +6: number of supplied arguments, +1
+ +8: ???
+
+ After linking
+ +0: SETHI global_temp (top 22 bits)
+ +4: JMPL global_temp (low 10 bits)
+ +8: NOP
+
+*/
+
+#define SPARC_CACHE_ARITY_OFFSET 5
+#define SPARC_CACHE_CODE_OFFSET 8
+
+
+#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) \
+{ \
+ (target) = \
+ ((long) \
+ (((unsigned short *) (address)) [SPARC_CACHE_ARITY_OFFSET]) & 0x0fff);\
+}
+
+#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) \
+{ \
+ (target) = (* (((SCHEME_OBJECT *) (address)))); \
+}
+
+/* Extract the target address (not the code to get there) from an
+ execute cache cell.
+ */
+
+#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) \
+{ \
+ unsigned long * addr = ((unsigned long*)(address)); \
+ unsigned long sethi_instr = addr[0]; \
+ unsigned long jmpl_instr = addr[1]; \
+ (target) = \
+ ((SCHEME_OBJECT) \
+ (((sethi_instr & 0x3fffff) << 10) | (jmpl_instr & 0x3ff))); \
+}
+
+/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS.
+ On the SPARC it must flush the I-cache, but there is no
+ need to flush the following ADDI instruction, which is a NOP.
+ */
+
+#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) \
+{ \
+ unsigned long * addr = (unsigned long *)(address); \
+ unsigned long target = (unsigned long)(entry); \
+ addr[0] = (addr[0] & SETHI_GLOBAL_TEMP_TEMPLATE) | (target >> 10); \
+ addr[1] = (addr[1] & JMPL_TEMPLATE) | (target & 0x000003ff); \
+}
+
+/* This stores the fixed part of the instructions leaving the
+ destination address and the number of arguments intact. These are
+ split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
+ NOT need to store the instructions back. On some architectures the
+ instructions may change due to GC and then STORE_EXECUTE_CACHE_CODE
+ should become a no-op and all of the work is done by
+ STORE_EXECUTE_CACHE_ADDRESS instead.
+ */
+
+
+#define STORE_EXECUTE_CACHE_CODE(address) \
+{ \
+ unsigned long* nop_addr = (((unsigned long *)(address)) + 2); \
+ unsigned long nop_val; \
+ *((unsigned long *)address) = (SETHI_GLOBAL_TEMP_TEMPLATE); \
+ *(((unsigned long *)(address))+1) = JMPL_TEMPLATE; \
+ nop_val = (*nop_addr); \
+ (*nop_addr) = ADDI(0,0,nop_val); \
+}
+
+/* This flushes the Scheme portion of the I-cache.
+ It is used after a GC or disk-restore.
+ It's needed because the GC has moved code around, and closures
+ and execute cache cells have absolute addresses that the
+ processor might have old copies of.
+ */
+
+#define FLUSH_I_CACHE() do \
+{ \
+ ICACHEFLUSH (Heap_Bottom, \
+ ((sizeof(SCHEME_OBJECT)) * \
+ (Heap_Top - Heap_Bottom))); \
+ ICACHEFLUSH (Constant_Space, \
+ ((sizeof(SCHEME_OBJECT)) * \
+ (Constant_Top - Constant_Space))); \
+ ICACHEFLUSH (Stack_Pointer, \
+ ((sizeof(SCHEME_OBJECT)) * \
+ (Stack_Top - Stack_Pointer))); \
+} while (0)
+
+
+/* This flushes a region of the I-cache.
+ It is used after updating an execute cache while running.
+ Not needed during GC because FLUSH_I_CACHE will be used.
+ */
+
+#define FLUSH_I_CACHE_REGION(address, nwords) do \
+{ \
+ ICACHEFLUSH ((address), ((sizeof (long)) * (nwords))); \
+} while (0)
+
+#define PUSH_D_CACHE_REGION FLUSH_I_CACHE_REGION
+
+/* The following is misnamed.
+ It should really be called STORE_BACK_D_CACHE.
+ Neither the R2000 nor the R3000 systems have them.
+ I don't know about the R4000 or R6000.
+ */
+
+/* #define SPLIT_CACHES */
+
+#ifdef IN_CMPINT_C
+
+
+#define CLOSURE_ENTRY_WORDS \
+ (COMPILED_CLOSURE_ENTRY_SIZE / (sizeof (SCHEME_OBJECT)))
+
+static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS);
+
+#define REGBLOCK_CLOSURE_LIMIT REGBLOCK_CLOSURE_SPACE
+
+/* The apparently random instances of the number 3 below arise from
+ the convention that free_closure always points to a JAL instruction
+ with (at least) 3 unused words preceding it.
+ In this way, if there is enough space, we can use free_closure
+ as the address of a new uni- or multi-closure.
+
+ The code below (in the initialization loop) depends on knowing that
+ CLOSURE_ENTRY_WORDS is 3.
+
+ Random hack: ADDI instructions look like TC_TRUE objects, thus of the
+ pre-initialized words, only the JALR looks like a pointer object
+ (an SCODE-QUOTE). Since there is exactly one JALR of waste between
+ closures, and it is always 3 words before free_closure,
+ the code for uni-closure allocation (in mips.m4) bashes that word
+ with 0 (SHARP_F) to make the heap parseable.
+ */
+
+/* size in Scheme objects of the block we need to allocate. */
+
+void
+DEFUN (allocate_closure, (size), long size)
+{
+ long space;
+ SCHEME_OBJECT * free_closure, * limit;
+
+ free_closure = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_FREE]);
+ limit = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_LIMIT]);
+ space = ((limit - free_closure) + 3);
+
+ /* Bump up to a multiple of CLOSURE_ENTRY_WORDS.
+ Otherwise clearing by the allocation code may clobber
+ a different word.
+ */
+ size = (CLOSURE_ENTRY_WORDS
+ * ((size + (CLOSURE_ENTRY_WORDS - 1))
+ / CLOSURE_ENTRY_WORDS));
+ if (size > space)
+ {
+ long chunk_size;
+ SCHEME_OBJECT *ptr;
+
+ /* Make the heap be parseable forward by protecting the waste
+ in the last chunk.
+ */
+
+ if ((space > 0) && (free_closure != ((SCHEME_OBJECT) NULL)))
+ free_closure[-3] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (space - 1)));
+
+ free_closure = Free;
+ if ((size <= closure_chunk) && (!(GC_Check (closure_chunk))))
+ limit = (free_closure + closure_chunk);
+ else
+ {
+ if (GC_Check (size))
+ {
+ if ((Heap_Top - Free) < size)
+ {
+ /* No way to back out -- die. */
+ fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size);
+ Microcode_Termination (TERM_NO_SPACE);
+ /* NOTREACHED */
+ }
+ Request_GC (0);
+ }
+ else if (size <= closure_chunk)
+ Request_GC (0);
+ limit = (free_closure + size);
+ }
+ Free = limit;
+ chunk_size = (limit - free_closure);
+
+ ptr = free_closure;
+ while (ptr < limit)
+ {
+ *ptr++ = (JALR (COMP_REG_LINKAGE, COMP_REG_CLOSURE_HOOK));
+ *ptr++ = (ADDI (COMP_REG_LINKAGE, COMP_REG_LINKAGE, -8));
+ *ptr++ = SHARP_F;
+ }
+ PUSH_D_CACHE_REGION (free_closure, chunk_size);
+ Registers[REGBLOCK_CLOSURE_LIMIT] = ((SCHEME_OBJECT) limit);
+ Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) (free_closure + 3));
+ }
+ return;
+}
+
+#endif /* IN_CMPINT_C */
+\f
+/* Derived parameters and macros.
+
+ These macros expect the above definitions to be meaningful.
+ If they are not, the macros below may have to be changed as well.
+ */
+
+#define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1])
+#define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2])
+
+/* The next one assumes 2's complement integers....*/
+#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
+#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
+
+#if (PC_ZERO_BITS == 0)
+/* Instructions aligned on byte boundaries */
+#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
+#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
+ ((CLEAR_LOW_BIT(offset_word)) >> 1)
+#endif
+
+#if (PC_ZERO_BITS == 1)
+/* Instructions aligned on word (16 bit) boundaries */
+#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
+#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
+ (CLEAR_LOW_BIT(offset_word))
+#endif
+
+#if (PC_ZERO_BITS >= 2)
+/* Should be OK for =2, but bets are off for >2 because of problems
+ mentioned earlier!
+*/
+#define SHIFT_AMOUNT (PC_ZERO_BITS - 1)
+#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT))
+#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
+ ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT))
+#endif
+
+#define MAKE_OFFSET_WORD(entry, block, continue) \
+ ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
+ ((char *) (block)))) | \
+ ((continue) ? 1 : 0))
+
+#if (EXECUTE_CACHE_ENTRY_SIZE == 2)
+#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
+ ((count) >> 1)
+#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
+ ((entries) << 1)
+#endif
+
+#if (EXECUTE_CACHE_ENTRY_SIZE == 4)
+#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
+ ((count) >> 2)
+#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
+ ((entries) << 2)
+#endif
+
+#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
+#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
+ ((count) / EXECUTE_CACHE_ENTRY_SIZE)
+#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
+ ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
+#endif
+\f
+/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
+ a format word and a gc offset word. See the early part of the
+ TRAMPOLINE picture, above.
+ */
+
+#define CC_BLOCK_FIRST_ENTRY_OFFSET \
+ (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
+
+/* Format words */
+
+#define FORMAT_BYTE_EXPR 0xFF
+#define FORMAT_BYTE_COMPLR 0xFE
+#define FORMAT_BYTE_CMPINT 0xFD
+#define FORMAT_BYTE_DLINK 0xFC
+#define FORMAT_BYTE_RETURN 0xFB
+
+#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
+#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
+#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
+
+/* This assumes that a format word is at least 16 bits,
+ and the low order field is always 8 bits.
+ */
+
+#define MAKE_FORMAT_WORD(field1, field2) \
+ (((field1) << 8) | ((field2) & 0xff))
+
+#define SIGN_EXTEND_FIELD(field, size) \
+ (((field) & ((1 << (size)) - 1)) | \
+ ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
+ ((-1) << (size))))
+
+#define FORMAT_WORD_LOW_BYTE(word) \
+ (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8))
+
+#define FORMAT_WORD_HIGH_BYTE(word) \
+ (SIGN_EXTEND_FIELD \
+ ((((unsigned long) (word)) >> 8), \
+ (((sizeof (format_word)) * CHAR_BIT) - 8)))
+
+#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
+ (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
+
+#define COMPILED_ENTRY_FORMAT_LOW(addr) \
+ (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
+
+#define FORMAT_BYTE_FRAMEMAX 0x7f
+
+#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
+#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
+
+#endif /* CMPINT2_H_INCLUDED */
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/coerce.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+(declare (usual-integrations))
+\f
+;;;; SPARC coercions
+
+;;; Coercion top level
+
+(define make-coercion
+ (coercion-maker
+ `((UNSIGNED . ,coerce-unsigned-integer)
+ (SIGNED . ,coerce-signed-integer))))
+
+(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1))
+(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
+(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
+(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4))
+(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
+(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
+(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
+(define coerce-9-bit-unsigned (make-coercion 'UNSIGNED 9))
+(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10))
+(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11))
+(define coerce-13-bit-unsigned (make-coercion 'UNSIGNED 13))
+(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15))
+(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
+(define coerce-20-bit-unsigned (make-coercion 'UNSIGNED 20))
+(define coerce-22-bit-unsigned (make-coercion 'UNSIGNED 22))
+(define coerce-25-bit-unsigned (make-coercion 'UNSIGNED 25))
+(define coerce-26-bit-unsigned (make-coercion 'UNSIGNED 26))
+(define coerce-30-bit-unsigned (make-coercion 'UNSIGNED 30))
+(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
+
+(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
+(define coerce-13-bit-signed (make-coercion 'SIGNED 13))
+(define coerce-22-bit-signed (make-coercion 'SIGNED 22))
+(define coerce-26-bit-signed (make-coercion 'SIGNED 26))
+(define coerce-30-bit-signed (make-coercion 'SIGNED 30))
+(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/decls.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+$MC68020-Header: decls.scm,v 4.27 90/05/03 15:17:08 GMT jinx Exp $
+
+Copyright (c) 1988-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler File Dependencies
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (add-event-receiver! event:after-restore reset-source-nodes!)
+ (reset-source-nodes!))
+
+(define (reset-source-nodes!)
+ (set! source-filenames '())
+ (set! source-hash)
+ (set! source-nodes)
+ (set! source-nodes/by-rank))
+
+(define (maybe-setup-source-nodes!)
+ (if (null? source-filenames)
+ (setup-source-nodes!)))
+
+(define (setup-source-nodes!)
+ (let ((filenames
+ (mapcan (lambda (subdirectory)
+ (map (lambda (pathname)
+ (string-append subdirectory
+ "/"
+ (pathname-name pathname)))
+ (directory-read
+ (string-append subdirectory
+ "/"
+ source-file-expression))))
+ '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
+ "machines/sparc"))))
+ (if (null? filenames)
+ (error "Can't find source files of compiler"))
+ (set! source-filenames filenames))
+ (set! source-hash
+ (make/hash-table
+ 101
+ string-hash-mod
+ (lambda (filename source-node)
+ (string=? filename (source-node/filename source-node)))
+ make/source-node))
+ (set! source-nodes
+ (map (lambda (filename)
+ (hash-table/intern! source-hash
+ filename
+ identity-procedure
+ identity-procedure))
+ source-filenames))
+ (initialize/syntax-dependencies!)
+ (initialize/integration-dependencies!)
+ (initialize/expansion-dependencies!)
+ (source-nodes/rank!))
+
+(define source-file-expression "*.scm")
+(define source-filenames)
+(define source-hash)
+(define source-nodes)
+(define source-nodes/by-rank)
+
+(define (filename/append directory . names)
+ (map (lambda (name) (string-append directory "/" name)) names))
+\f
+(define-structure (source-node
+ (conc-name source-node/)
+ (constructor make/source-node (filename)))
+ (filename false read-only true)
+ (pathname (string->pathname filename) read-only true)
+ (forward-links '())
+ (backward-links '())
+ (forward-closure '())
+ (backward-closure '())
+ (dependencies '())
+ (dependents '())
+ (rank false)
+ (syntax-table false)
+ (declarations '())
+ (modification-time false))
+
+(define (filename->source-node filename)
+ (hash-table/lookup source-hash
+ filename
+ identity-procedure
+ (lambda () (error "Unknown source file" filename))))
+
+(define (source-node/circular? node)
+ (memq node (source-node/backward-closure node)))
+
+(define (source-node/link! node dependency)
+ (if (not (memq dependency (source-node/backward-links node)))
+ (begin
+ (set-source-node/backward-links!
+ node
+ (cons dependency (source-node/backward-links node)))
+ (set-source-node/forward-links!
+ dependency
+ (cons node (source-node/forward-links dependency)))
+ (source-node/close! node dependency))))
+
+(define (source-node/close! node dependency)
+ (if (not (memq dependency (source-node/backward-closure node)))
+ (begin
+ (set-source-node/backward-closure!
+ node
+ (cons dependency (source-node/backward-closure node)))
+ (set-source-node/forward-closure!
+ dependency
+ (cons node (source-node/forward-closure dependency)))
+ (for-each (lambda (dependency)
+ (source-node/close! node dependency))
+ (source-node/backward-closure dependency))
+ (for-each (lambda (node)
+ (source-node/close! node dependency))
+ (source-node/forward-closure node)))))
+\f
+;;;; Rank
+
+(define (source-nodes/rank!)
+ (compute-dependencies! source-nodes)
+ (compute-ranks! source-nodes)
+ (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes)))
+
+(define (compute-dependencies! nodes)
+ (for-each (lambda (node)
+ (set-source-node/dependencies!
+ node
+ (list-transform-negative (source-node/backward-closure node)
+ (lambda (node*)
+ (memq node (source-node/backward-closure node*)))))
+ (set-source-node/dependents!
+ node
+ (list-transform-negative (source-node/forward-closure node)
+ (lambda (node*)
+ (memq node (source-node/forward-closure node*))))))
+ nodes))
+
+(define (compute-ranks! nodes)
+ (let loop ((nodes nodes) (unranked-nodes '()))
+ (if (null? nodes)
+ (if (not (null? unranked-nodes))
+ (loop unranked-nodes '()))
+ (loop (cdr nodes)
+ (let ((node (car nodes)))
+ (let ((rank (source-node/rank* node)))
+ (if rank
+ (begin
+ (set-source-node/rank! node rank)
+ unranked-nodes)
+ (cons node unranked-nodes))))))))
+
+(define (source-node/rank* node)
+ (let loop ((nodes (source-node/dependencies node)) (rank -1))
+ (if (null? nodes)
+ (1+ rank)
+ (let ((rank* (source-node/rank (car nodes))))
+ (and rank*
+ (loop (cdr nodes) (max rank rank*)))))))
+
+(define (source-nodes/sort-by-rank nodes)
+ (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
+\f
+;;;; File Syntaxer
+
+(define (syntax-files!)
+ (maybe-setup-source-nodes!)
+ (for-each
+ (lambda (node)
+ (let ((modification-time
+ (let ((source (modification-time node "scm"))
+ (binary (modification-time node "bin")))
+ (if (not source)
+ (error "Missing source file" (source-node/filename node)))
+ (and binary (< source binary) binary))))
+ (set-source-node/modification-time! node modification-time)
+ (if (not modification-time)
+ (begin (write-string "\nSource file newer than binary: ")
+ (write (source-node/filename node))))))
+ source-nodes)
+ (if compiler:enable-integration-declarations?
+ (begin
+ (for-each
+ (lambda (node)
+ (let ((time (source-node/modification-time node)))
+ (if (and time
+ (there-exists? (source-node/dependencies node)
+ (lambda (node*)
+ (let ((newer?
+ (let ((time*
+ (source-node/modification-time node*)))
+ (or (not time*)
+ (> time* time)))))
+ (if newer?
+ (begin
+ (write-string "\nBinary file ")
+ (write (source-node/filename node))
+ (write-string " newer than dependency ")
+ (write (source-node/filename node*))))
+ newer?))))
+ (set-source-node/modification-time! node false))))
+ source-nodes)
+ (for-each
+ (lambda (node)
+ (if (not (source-node/modification-time node))
+ (for-each (lambda (node*)
+ (if (source-node/modification-time node*)
+ (begin
+ (write-string "\nBinary file ")
+ (write (source-node/filename node*))
+ (write-string " depends on ")
+ (write (source-node/filename node))))
+ (set-source-node/modification-time! node* false))
+ (source-node/forward-closure node))))
+ source-nodes)))
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (pathname-delete!
+ (pathname-new-type (source-node/pathname node) "ext"))))
+ source-nodes/by-rank)
+ (write-string "\n\nBegin pass 1:")
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (source-node/syntax! node)))
+ source-nodes/by-rank)
+ (if (there-exists? source-nodes/by-rank
+ (lambda (node)
+ (and (not (source-node/modification-time node))
+ (source-node/circular? node))))
+ (begin
+ (write-string "\n\nBegin pass 2:")
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (if (source-node/circular? node)
+ (source-node/syntax! node)
+ (source-node/touch! node))))
+ source-nodes/by-rank))))
+\f
+(define (source-node/touch! node)
+ (with-values
+ (lambda ()
+ (sf/pathname-defaulting (source-node/pathname node) "" false))
+ (lambda (input-pathname bin-pathname spec-pathname)
+ input-pathname
+ (pathname-touch! bin-pathname)
+ (pathname-touch! (pathname-new-type bin-pathname "ext"))
+ (if spec-pathname (pathname-touch! spec-pathname)))))
+
+(define (pathname-touch! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-string "\nTouch file: ")
+ (write (pathname->string pathname))
+ (file-touch pathname))))
+
+(define (pathname-delete! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-string "\nDelete file: ")
+ (write (pathname->string pathname))
+ (delete-file pathname))))
+
+(define (sc filename)
+ (maybe-setup-source-nodes!)
+ (source-node/syntax! (filename->source-node filename)))
+
+(define (source-node/syntax! node)
+ (with-values
+ (lambda ()
+ (sf/pathname-defaulting (source-node/pathname node) "" false))
+ (lambda (input-pathname bin-pathname spec-pathname)
+ (sf/internal
+ input-pathname bin-pathname spec-pathname
+ (source-node/syntax-table node)
+ ((if compiler:enable-integration-declarations?
+ identity-procedure
+ (lambda (declarations)
+ (list-transform-negative declarations
+ integration-declaration?)))
+ ((if compiler:enable-expansion-declarations?
+ identity-procedure
+ (lambda (declarations)
+ (list-transform-negative declarations
+ expansion-declaration?)))
+ (source-node/declarations node)))))))
+
+(define-integrable (modification-time node type)
+ (file-modification-time
+ (pathname-new-type (source-node/pathname node) type)))
+\f
+;;;; Syntax dependencies
+
+(define (initialize/syntax-dependencies!)
+ (let ((file-dependency/syntax/join
+ (lambda (filenames syntax-table)
+ (for-each (lambda (filename)
+ (set-source-node/syntax-table!
+ (filename->source-node filename)
+ syntax-table))
+ filenames))))
+ (file-dependency/syntax/join
+ (append (filename/append "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "constr"
+ "contin" "crstop" "ctypes" "debug" "enumer"
+ "infnew" "lvalue" "object" "pmerly" "proced"
+ "refctx" "rvalue" "scode" "sets" "subprb"
+ "switch" "toplev" "utils")
+ (filename/append "back"
+ "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
+ "lapgn2" "lapgn3" "linear" "regmap" "symtab"
+ "syntax")
+ (filename/append "machines/sparc"
+ "insmac" "lapopt" "machin" "rulrew" "rgspcm")
+ (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/sparc"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo")
+ lap-generator-syntax-table)
+ (file-dependency/syntax/join
+ (filename/append "machines/sparc"
+ "instr1" "instr2a" "instr2b" "instr3")
+ assembler-syntax-table)))
+\f
+;;;; Integration Dependencies
+
+(define (initialize/integration-dependencies!)
+
+ (define (add-declaration! declaration filenames)
+ (for-each (lambda (filenames)
+ (let ((node (filename->source-node filenames)))
+ (set-source-node/declarations!
+ node
+ (cons declaration
+ (source-node/declarations node)))))
+ filenames))
+
+ (let* ((front-end-base
+ (filename/append "base"
+ "blocks" "cfg1" "cfg2" "cfg3"
+ "contin" "ctypes" "enumer" "lvalue"
+ "object" "proced" "rvalue"
+ "scode" "subprb" "utils"))
+ (sparc-base
+ (filename/append "machines/sparc" "machin"))
+ (rtl-base
+ (filename/append "rtlbase"
+ "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/sparc" "assmd" "machin"))
+ (lapgen-base
+ (append (filename/append "back" "lapgn3" "regmap")
+ (filename/append "machines/sparc" "lapgen")))
+ (assembler-base
+ (append (filename/append "back" "symtab")
+ (filename/append "machines/sparc" "instr1")))
+ (lapgen-body
+ (append
+ (filename/append "back" "lapgn1" "lapgn2" "syntax")
+ (filename/append "machines/sparc"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo")))
+ (assembler-body
+ (append
+ (filename/append "back" "bittop")
+ (filename/append "machines/sparc"
+ "instr1" "instr2a" "instr2b" "instr3"))))
+
+ (define (file-dependency/integration/join filenames dependencies)
+ (for-each (lambda (filename)
+ (file-dependency/integration/make filename dependencies))
+ filenames))
+
+ (define (file-dependency/integration/make filename dependencies)
+ (let ((node (filename->source-node filename)))
+ (for-each (lambda (dependency)
+ (let ((node* (filename->source-node dependency)))
+ (if (not (eq? node node*))
+ (source-node/link! node node*))))
+ dependencies)))
+
+ (define (define-integration-dependencies directory name directory* . names)
+ (file-dependency/integration/make
+ (string-append directory "/" name)
+ (apply filename/append directory* names)))
+
+ (define-integration-dependencies "base" "object" "base" "enumer")
+ (define-integration-dependencies "base" "enumer" "base" "object")
+ (define-integration-dependencies "base" "utils" "base" "scode")
+ (define-integration-dependencies "base" "cfg1" "base" "object")
+ (define-integration-dependencies "base" "cfg2" "base"
+ "cfg1" "cfg3" "object")
+ (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "base" "ctypes" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
+ (define-integration-dependencies "base" "rvalue" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
+ (define-integration-dependencies "base" "lvalue" "base"
+ "blocks" "object" "proced" "rvalue" "utils")
+ (define-integration-dependencies "base" "blocks" "base"
+ "enumer" "lvalue" "object" "proced" "rvalue" "scode")
+ (define-integration-dependencies "base" "proced" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
+ "rvalue" "utils")
+ (define-integration-dependencies "base" "contin" "base"
+ "blocks" "cfg3" "ctypes")
+ (define-integration-dependencies "base" "subprb" "base"
+ "cfg3" "contin" "enumer" "object" "proced")
+
+ (define-integration-dependencies "machines/sparc" "machin" "rtlbase"
+ "rtlreg" "rtlty1" "rtlty2")
+
+ (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rgraph" "machines/sparc"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlcfg" "base"
+ "cfg1" "cfg2" "cfg3")
+ (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
+ (define-integration-dependencies "rtlbase" "rtlcon" "machines/sparc"
+ "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/sparc"
+ "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/sparc"
+ "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 sparc-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 sparc-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/sparc" "rulrew"))
+ (append sparc-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"
+ "rgraph" "rtlcfg")
+ (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
+ (define-integration-dependencies "back" "lapgn3" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "back" "mermap" "back" "regmap")
+ (define-integration-dependencies "back" "regmap" "base" "utils")
+ (define-integration-dependencies "back" "symtab" "base" "utils"))
+
+ (for-each (lambda (node)
+ (let ((links (source-node/backward-links node)))
+ (if (not (null? links))
+ (set-source-node/declarations!
+ node
+ (cons (make-integration-declaration
+ (source-node/pathname node)
+ (map source-node/pathname links))
+ (source-node/declarations node))))))
+ source-nodes))
+
+(define (make-integration-declaration pathname integration-dependencies)
+ `(INTEGRATE-EXTERNAL
+ ,@(map (let ((default
+ (make-pathname
+ false
+ false
+ (make-list (length (pathname-directory pathname)) 'UP)
+ false
+ false
+ false)))
+ (lambda (pathname)
+ (merge-pathnames pathname default)))
+ integration-dependencies)))
+
+(define-integrable (integration-declaration? declaration)
+ (eq? (car declaration) 'INTEGRATE-EXTERNAL))
+\f
+;;;; Expansion Dependencies
+
+(define (initialize/expansion-dependencies!)
+ (let ((file-dependency/expansion/join
+ (lambda (filenames expansions)
+ (for-each (lambda (filename)
+ (let ((node (filename->source-node filename)))
+ (set-source-node/declarations!
+ node
+ (cons (make-expansion-declaration expansions)
+ (source-node/declarations node)))))
+ filenames))))
+ (file-dependency/expansion/join
+ (filename/append "machines/sparc"
+ "lapgen" "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo")
+ (map (lambda (entry)
+ `(,(car entry)
+ (PACKAGE/REFERENCE (FIND-PACKAGE '(COMPILER LAP-SYNTAXER))
+ ',(cadr entry))))
+ '((LAP:SYNTAX-INSTRUCTION LAP:SYNTAX-INSTRUCTION-EXPANDER)
+ (INSTRUCTION->INSTRUCTION-SEQUENCE
+ INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER)
+ (SYNTAX-EVALUATION SYNTAX-EVALUATION-EXPANDER)
+ (CONS-SYNTAX CONS-SYNTAX-EXPANDER)
+ (OPTIMIZE-GROUP-EARLY OPTIMIZE-GROUP-EXPANDER)
+ (EA-KEYWORD-EARLY EA-KEYWORD-EXPANDER)
+ (EA-MODE-EARLY EA-MODE-EXPANDER)
+ (EA-REGISTER-EARLY EA-REGISTER-EXPANDER)
+ (EA-EXTENSION-EARLY EA-EXTENSION-EXPANDER)
+ (EA-CATEGORIES-EARLY EA-CATEGORIES-EXPANDER))))))
+
+(define-integrable (make-expansion-declaration expansions)
+ `(EXPAND-OPERATOR ,@expansions))
+
+(define-integrable (expansion-declaration? declaration)
+ (eq? (car declaration) 'EXPAND-OPERATOR))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/inerly.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+$MC68020-Header: inerly.scm,v 1.6 88/08/31 06:00:59 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;; SPARC Instruction Set Macros. Early version
+;;; NOPs for now.
+
+(declare (usual-integrations))
+\f
+;;;; Transformers and utilities
+
+(define early-instructions '())
+(define early-transformers '())
+
+(define (define-early-transformer name transformer)
+ (set! early-transformers
+ (cons (cons name transformer)
+ early-transformers)))
+
+(define (eq-subset? s1 s2)
+ (or (null? s1)
+ (and (memq (car s1) s2)
+ (eq-subset? (cdr s1) s2))))
+
+;;; Instruction and addressing mode macros
+
+(syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION
+ (macro (opcode . patterns)
+ `(SET! EARLY-INSTRUCTIONS
+ (CONS
+ (LIST ',opcode
+ ,@(map (lambda (pattern)
+ `(early-parse-rule
+ ',(car pattern)
+ (lambda (pat vars)
+ (early-make-rule
+ pat
+ vars
+ (scode-quote
+ (instruction->instruction-sequence
+ ,(parse-instruction (cadr pattern)
+ (cddr pattern)
+ true)))))))
+ patterns))
+ EARLY-INSTRUCTIONS))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/insmac.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1988-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SPARC Instruction Set Macros
+
+(declare (usual-integrations))
+\f
+;;;; Definition macros
+
+(syntax-table-define assembler-syntax-table 'DEFINE-SYMBOL-TRANSFORMER
+ (macro (name . alist)
+ `(BEGIN
+ (DECLARE (INTEGRATE-OPERATOR ,name))
+ (DEFINE (,name SYMBOL)
+ (DECLARE (INTEGRATE SYMBOL))
+ (LET ((PLACE (ASSQ SYMBOL ',alist)))
+ (IF (NULL? PLACE)
+ #F
+ (CDR PLACE)))))))
+
+(syntax-table-define assembler-syntax-table 'DEFINE-TRANSFORMER
+ (macro (name value)
+ `(DEFINE ,name ,value)))
+
+;;;; 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 (and (eq? endianness 'LITTLE)
+ (= 32 (+ word-size car-size)))
+ (expand '() 0 (cdr fields)
+ (lambda (tail tail-size)
+ (receiver
+ (append (cons car-field first-word) tail)
+ (+ car-size tail-size))))
+ (expand (cons car-field first-word)
+ (+ car-size word-size)
+ (cdr fields)
+ (lambda (tail tail-size)
+ (receiver
+ (if (or (zero? car-size)
+ (not (eq? endianness 'LITTLE)))
+ (cons car-field tail)
+ tail)
+ (+ car-size tail-size)))))))))
+ (expand '() 0 fields receiver))
+
+(define (expand-field field early? receiver)
+ early? ; ignored for now
+ (let ((size (car field))
+ (expression (cadr field)))
+
+ (define (default type)
+ (receiver (integer-syntaxer expression type size)
+ size))
+
+ (if (null? (cddr field))
+ (default 'UNSIGNED)
+ (case (caddr field)
+ ((PC-REL)
+ (receiver
+ (integer-syntaxer ``(- ,,expression (+ *PC* 4))
+ (cadddr field)
+ size)
+ size))
+ ((BLOCK-OFFSET)
+ (receiver (list 'list ''BLOCK-OFFSET expression)
+ size))
+ (else
+ (default (caddr field)))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/instr1.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1987-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; MIPS instruction set
+
+;; Branch-tensioned instructions are in instr2.scm
+;; Floating point instructions are in instr3.scm
+
+(declare (usual-integrations))
+\f
+(let-syntax
+ ((arithmetic-immediate-instruction
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? destination) (? source) (? immediate))
+ (VARIABLE-WIDTH (evaluated-immediate immediate)
+ ((#x-2000 #x1fff)
+ (LONG (2 2)
+ (5 destination)
+ (6 ,opcode)
+ (5 source)
+ (1 1)
+ (13 evaluated-immediate SIGNED)))
+ ((() ())
+ ;; SETHI $1, top(immediate)
+ ;; OR $1, bottom(immediate)
+ ;; reg-op $destination, $source, $1
+ (LONG (2 0)
+ (5 1)
+ (3 4)
+ (22 evaluated-immediate) ; SETHI
+ (2 2)
+ (5 1)
+ (6 2)
+ (5 1)
+ (1 1)
+ (13 evaluated-immediate SIGNED) ; OR
+ (2 0)
+ (5 destination)
+ (6 ,opcode)
+ (5 source)
+ (1 0)
+ (8 0)
+ (5 1))))))))) ; reg-op
+ (arithmetic-immediate-instruction addi 0)
+ (arithmetic-immediate-instruction addcci 16)
+ (arithmetic-immediate-instruction addxi 8)
+ (arithmetic-immediate-instruction addxcci 24)
+ (arithmetic-immediate-instruction andi 1)
+ (arithmetic-immediate-instruction andcci 17)
+ (arithmetic-immediate-instruction andni 5)
+ (arithmetic-immediate-instruction andncci 21)
+ (arithmetic-immediate-instruction ori 2)
+ (arithmetic-immediate-instruction orcci 18)
+ (arithmetic-immediate-instruction orni 6)
+ (arithmetic-immediate-instruction orncci 22)
+ (arithmetic-immediate-instruction xori 3)
+ (arithmetic-immediate-instruction xorcci 19)
+ (arithmetic-immediate-instruction xnori 7)
+ (arithmetic-immediate-instruction xnorcc 23)
+ (arithmetic-immediate-instruction subi 4)
+ (arithmetic-immediate-instruction subcci 20)
+ (arithmetic-immediate-instruction subxi 12)
+ (arithmetic-immediate-instruction subxcci 28)
+ (arithmetic-immediate-instruction umuli 10)
+ (arithmetic-immediate-instruction smuli 11)
+ (arithmetic-immediate-instruction umulcci 26)
+ (arithmetic-immediate-instruction smulcci 27)
+ (arithmetic-immediate-instruction udivi 14)
+ (arithmetic-immediate-instruction sdivi 15)
+ (arithmetic-immediate-instruction udivcci 30)
+ (arithmetic-immediate-instruction sdivcci 31)
+ )
+
+\f
+(define-instruction lui
+ (((? destination) (? immediate))
+ (LONG (6 15)
+ (5 0)
+ (5 destination)
+ (16 immediate))))
+
+(define-instruction li
+ (((? destination) (? immediate))
+ (VARIABLE-WIDTH (evaluated-immediate immediate)
+ ((#x-2000 #x1fff)
+ (LONG (2 2)
+ (5 destination)
+ (6 2)
+ (5 0)
+ (1 1)
+ (13 evaluated-immediate SIGNED)))
+ ((() ())
+ ;; SETHI $1, top(immediate)
+ ;; OR $1, bottom(immediate)
+ (LONG (2 0)
+ (5 1)
+ (3 4)
+ (22 (high-bits evaluated-immediate)) ; SETHI
+ (2 2)
+ (5 1)
+ (6 2)
+ (5 1)
+ (1 1)
+ (13 (low-bits evaluated-immediate) SIGNED) ; OR
+ )))))
+
+\f
+(let-syntax
+ ((3-operand-instruction
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? destination) (? source-1) (? source-2))
+ (LONG (2 2)
+ (5 destination)
+ (6 ,opcode)
+ (5 source-1)
+ (1 0)
+ (8 0)
+ (5 source-2)
+ ))))))
+ (3-operand-instruction add 0)
+ (3-operand-instruction addcc 16)
+ (3-operand-instruction addx 8)
+ (3-operand-instruction addxcc 24)
+ (3-operand-instruction andr 1)
+ (3-operand-instruction andcc 17)
+ (3-operand-instruction andn 5)
+ (3-operand-instruction andncc 21)
+ (3-operand-instruction orr 2)
+ (3-operand-instruction orcc 18)
+ (3-operand-instruction orn 6)
+ (3-operand-instruction orncc 22)
+ (3-operand-instruction xorr 3)
+ (3-operand-instruction xorcc 19)
+ (3-operand-instruction xnor 7)
+ (3-operand-instruction xnorcc 23)
+ (3-operand-instruction sllv 37)
+ (3-operand-instruction srlv 38)
+ (3-operand-instruction srav 39)
+ (3-operand-instruction subr 4)
+ (3-operand-instruction subcc 20)
+ (3-operand-instruction subx 12)
+ (3-operand-instruction umul 10)
+ (3-operand-instruction smul 11)
+ (3-operand-instruction umulcc 26)
+ (3-operand-instruction smulcc 27)
+ (3-operand-instruction udiv 14)
+ (3-operand-instruction sdiv 15)
+ (3-operand-instruction udivcc 30)
+ (3-operand-instruction sdivcc 31)
+ )
+
+
+(let-syntax
+ ((shift-instruction-immediate
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? destination) (? source) (? amount))
+ (LONG (2 2)
+ (5 destination)
+ (6 ,opcode)
+ (5 source)
+ (1 1)
+ (8 0)
+ (5 amount)
+ ))))))
+ (shift-instruction-immediate sll 37)
+ (shift-instruction-immediate srl 38)
+ (shift-instruction-immediate sra 39))
+
+\f
+
+(define-instruction jalr
+ (((? destination) (? source))
+ (LONG (2 2)
+ (5 destination)
+ (6 56)
+ (5 source)
+ (1 0)
+ (8 0)
+ (5 0))))
+
+(define-instruction jr
+ (((? source))
+ (LONG (2 2)
+ (5 0)
+ (6 56)
+ (5 source)
+ (1 0)
+ (8 0)
+ (5 0))))
+
+(define-instruction jmpl
+ (((? destination) (? source1) (? source2))
+ (LONG (2 2)
+ (5 destination)
+ (6 56)
+ (5 source1)
+ (1 0)
+ (8 0)
+ (5 source2))))
+
+(define-instruction call
+ (((? offset))
+ (LONG (2 1)
+ (30 (quotient offset 4) SIGNED))))
+
+(define-instruction sethi
+ (((? destination) (? bits))
+ (LONG (2 0)
+ (5 destination)
+ (3 4)
+ (22 (top-22-bits bits) UNSIGNED))))
+
+\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)))
+ (if (eq? endianness 'LITTLE)
+ (LONG (16 label BLOCK-OFFSET)
+ (16 format-word UNSIGNED))
+ (LONG (16 format-word UNSIGNED)
+ (16 label BLOCK-OFFSET)))))
+
+(define-instruction NOP
+ ;; SETHI $0, 0
+ (()
+ (LONG (2 0)
+ (5 0)
+ (3 4)
+ (22 0))))
+
+(define-instruction LONG
+ ((S (? value))
+ (LONG (32 value SIGNED)))
+ ((U (? value))
+ (LONG (32 value UNSIGNED))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/instr2a.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1987-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SPARC instruction set, part 2a
+
+(declare (usual-integrations))
+\f
+;;;; Instructions that require branch tensioning: branch
+
+(let-syntax
+ ((branch
+ (macro (keyword annul condition)
+ `(define-instruction ,keyword
+ (((@PCO (? offset)))
+ (LONG (2 0)
+ ,annul
+ ,condition
+ (3 2)
+ (22 (quotient offset 4) SIGNED)))
+ (((@PCR (? label)))
+ (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 0)) 4))
+ ((#x-400000 #x3fffff)
+ (LONG (2 0)
+ ,annul
+ ,condition
+ (3 2)
+ (22 offset SIGNED)))
+ ((() ())
+ ;; B??a condition, yyy
+ ;; JMPL xxx, $0
+ ;; yyy: SETHI $1, high(offset)
+ ;; OR $1, $1, low(offset)
+ ;; JMPL $1,$0
+ ;; xxx: fall through
+ (LONG (2 0)
+ (1 1) ; set anull bit, the JMPL is cancelled
+ ; on a taken branch
+ ,condition
+ (3 2)
+ (22 2 SIGNED) ; B??condition, yyy
+ (2 2)
+ (5 0)
+ (6 #x38)
+ (5 0)
+ (1 1)
+ (13 16 SIGNED) ; JMPL xxx, $0
+ (2 0)
+ (5 1)
+ (3 4)
+ (22 (high-bits (* offset 4)) SIGNED)
+ ; SETHI $1, high22(offset)
+ (2 2)
+ (5 1)
+ (6 2)
+ (5 1)
+ (1 1)
+ (13 (low-bits (* offset 4)) SIGNED)
+ ; OR $1, $1, low10(offset)
+ (2 2)
+ (5 0)
+ (6 #x38)
+ (5 1)
+ (1 0)
+ (8 0)
+ (5 0) ; JMPL $1,$0
+ ))))))))
+ (branch ba (1 0) (4 8))
+ (branch bn (1 0) (4 0))
+ (branch bne (1 0) (4 9))
+ (branch be (1 0) (4 1))
+ (branch bg (1 0) (4 10))
+ (branch ble (1 0) (4 2))
+ (branch bge (1 0) (4 11))
+ (branch bl (1 0) (4 3))
+ (branch bgu (1 0) (4 12))
+ (branch bleu (1 0) (4 4))
+ (branch bcc (1 0) (4 13))
+ (branch bcs (1 0) (4 5))
+ (branch bpos (1 0) (4 14))
+ (branch bneg (1 0) (4 6))
+ (branch bvc (1 0) (4 15))
+ (branch bvs (1 0) (4 7))
+ )
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/instr2b.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1987-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SPARC instruction set, part 2b
+
+(declare (usual-integrations))
+\f
+;;;; Instructions that require branch tensioning: load/store
+
+(let-syntax
+ ((load/store-instruction
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((? source/dest-reg) (OFFSET (? offset-ls) (? base-reg)))
+ (VARIABLE-WIDTH (delta offset-ls)
+ ((#x-fff #xfff)
+ (LONG (2 3)
+ (5 source/dest-reg)
+ (6 ,opcode)
+ (5 base-reg)
+ (1 1)
+ (13 delta SIGNED)))
+ ((() ())
+ ;; SETHI 1, %hi(offset)
+ ;; OR 1, 1, %lo(offset)
+ ;; LD source/dest-reg,1,base-reg
+ (LONG (2 0) ; SETHI
+ (5 1)
+ (3 4)
+ (22 (high-bits delta))
+
+ (2 2) ; OR
+ (5 1)
+ (6 2)
+ (5 1)
+ (1 1)
+ (13 (low-bits delta))
+
+ (2 3) ; LD
+ (5 source/dest-reg)
+ (6 ,opcode)
+ (5 1)
+ (1 0)
+ (8 0)
+ (5 base-reg)))))))))
+ (load/store-instruction ldsb 9)
+ (load/store-instruction ldsh 10)
+ (load/store-instruction ldub 1)
+ (load/store-instruction lduh 2)
+ (load/store-instruction ld 0)
+ (load/store-instruction ldd 3)
+ (load/store-instruction stb 5)
+ (load/store-instruction sth 6)
+ (load/store-instruction st 4)
+ (load/store-instruction std 7)
+ (load/store-instruction ldf 32)
+ (load/store-instruction lddf 35)
+ (load/store-instruction ldfsr 33)
+ (load/store-instruction stf 36)
+ (load/store-instruction ltdf 39)
+ (load/store-instruction stfsr 37)
+ )
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/instr3.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1987-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SPARC instruction set, part 3
+
+(declare (usual-integrations))
+\f
+(let-syntax
+ ((float-instruction-3
+ (macro (keyword major minor)
+ `(define-instruction ,keyword
+ (((? destination) (? source1) (? source2))
+ (LONG (2 2)
+ (5 destination)
+ (6 ,major)
+ (5 source1)
+ (9 ,minor)
+ (5 source2)))))))
+ (float-instruction-3 fadds 52 65)
+ (float-instruction-3 faddd 52 66)
+ (float-instruction-3 faddq 52 67)
+ (float-instruction-3 fsubs 52 69)
+ (float-instruction-3 fsubd 52 70)
+ (float-instruction-3 fsubq 52 71)
+ (float-instruction-3 fmuls 52 73)
+ (float-instruction-3 fmuld 52 74)
+ (float-instruction-3 fmulq 52 75)
+ (float-instruction-3 fsmuld 52 #x69)
+ (float-instruction-3 fdmulq 52 #x6e)
+ (float-instruction-3 fdivs 52 #x4d)
+ (float-instruction-3 fdivd 52 #x4e)
+ (float-instruction-3 fdivq 52 #x4f))
+
+(let-syntax
+ ((float-instruction-cmp
+ (macro (keyword major minor)
+ `(define-instruction ,keyword
+ (((? source1) (? source2))
+ (LONG (2 2)
+ (5 0)
+ (6 ,major)
+ (5 source1)
+ (9 ,minor)
+ (5 source2)))))))
+ (float-instruction-cmp fcmps 53 #x51)
+ (float-instruction-cmp fcmpd 53 #x52)
+ (float-instruction-cmp fcmpq 53 #x53)
+ (float-instruction-cmp fcmpes 53 #x55)
+ (float-instruction-cmp fcmped 53 #x56)
+ (float-instruction-cmp fcmpeq 53 #x57))
+
+(let-syntax
+ ((float-instruction-2
+ (macro (keyword major minor)
+ `(define-instruction ,keyword
+ (((? destination) (? source))
+ (LONG (2 2)
+ (5 destination)
+ (6 ,major)
+ (5 0)
+ (9 ,minor)
+ (5 source)))))))
+ (float-instruction-2 fsqrts #x34 #x29)
+ (float-instruction-2 fsqrtd #x34 #x2a)
+ (float-instruction-2 fsqrtq #x34 #x2b)
+
+ (float-instruction-2 fmovs #x34 #x01)
+ (float-instruction-2 fnegs #x34 #x05)
+ (float-instruction-2 fabss #x34 #x09)
+
+ (float-instruction-2 fstoi #x34 #xd1)
+ (float-instruction-2 fdtoi #x34 #xd2)
+ (float-instruction-2 fqtoi #x34 #xd3)
+
+ (float-instruction-2 fitos #x34 #xc4)
+ (float-instruction-2 fitod #x34 #xc8)
+ (float-instruction-2 fitoq #x34 #xcc)
+
+ (float-instruction-2 fstod #x34 #xc9)
+ (float-instruction-2 fstoq #x34 #xcd)
+
+ (float-instruction-2 fdtos #x34 #xc6)
+ (float-instruction-2 fstod #x34 #xce)
+
+ (float-instruction-2 fstod #x34 #xc7)
+ (float-instruction-2 fstod #x34 #xcb))
+
+
+
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/lapgen.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rules for SPARC. Shared utilities.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Register-Allocator Interface
+
+(define (register->register-transfer source target)
+ (if (not (register-types-compatible? source target))
+ (error "Moving between incompatible register types" source target))
+ (case (register-type source)
+ ((GENERAL) (copy source target))
+ ((FLOAT) (fp-copy source target))
+ (else (error "unknown register type" source))))
+
+(define (home->register-transfer source target)
+ (memory->register-transfer (pseudo-register-displacement source)
+ regnum:regs-pointer
+ target))
+
+(define (register->home-transfer source target)
+ (register->memory-transfer source
+ (pseudo-register-displacement target)
+ regnum:regs-pointer))
+
+(define (reference->register-transfer source target)
+ (case (ea/mode source)
+ ((GR)
+ (copy (register-ea/register source) target))
+ ((FPR)
+ (fp-copy (fpr->float-register (register-ea/register source)) target))
+ ((OFFSET)
+ (memory->register-transfer (offset-ea/offset source)
+ (offset-ea/register source)
+ target))
+ (else
+ (error "unknown effective-address mode" source))))
+
+(define (pseudo-register-home register)
+ ;; Register block consists of 16 4-byte registers followed by 256
+ ;; 8-byte temporaries.
+ (INST-EA (OFFSET ,(pseudo-register-displacement register)
+ ,regnum:regs-pointer)))
+\f
+(define-integrable (sort-machine-registers registers)
+ registers)
+
+(define available-machine-registers
+ (list
+ ;; g0 g1
+ g2 g3 g4
+ ;; g5 g6 g7
+
+ g22 g23 ;; g24
+ g28 g29 g30
+
+ g8 g9 g10 g11 g12 g13
+
+ ;; g14 g15
+ ;; g16 g17 g18 g19 g20 g21 g22
+ ;; g25 g26 g27 g28
+ ;; g31 ; could be available if handled right
+
+ fp0 fp2 fp4 fp6 fp8 fp10 fp12 fp14
+ fp16 fp18 fp20 fp22 fp24 fp26 fp28 fp30
+ ;; fp1 fp3 fp5 fp7 fp9 fp11 fp13 fp15
+ ;; fp17 fp19 fp21 fp23 fp25 fp27 fp29 fp31
+ ))
+
+(define-integrable (float-register? register)
+ (eq? (register-type register) 'FLOAT))
+
+(define-integrable (general-register? register)
+ (eq? (register-type register) 'GENERAL))
+
+(define-integrable (word-register? register)
+ (eq? (register-type register) 'GENERAL))
+
+(define (register-types-compatible? type1 type2)
+ (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
+
+(define (register-type register)
+ (cond ((machine-register? register)
+ (vector-ref
+ '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
+ register))
+ ((register-value-class=word? register) 'GENERAL)
+ ((register-value-class=float? register) 'FLOAT)
+ (else (error "unable to determine register type" register))))
+
+(define register-reference
+ (let ((references (make-vector number-of-machine-registers)))
+ (let loop ((register 0))
+ (if (< register 32)
+ (begin
+ (vector-set! references register (INST-EA (GR ,register)))
+ (loop (1+ register)))))
+ (let loop ((register 32) (fpr 0))
+ (if (< register 48)
+ (begin
+ (vector-set! references register (INST-EA (FPR ,fpr)))
+ (loop (1+ register) (1+ fpr)))))
+ (lambda (register)
+ (vector-ref references register))))
+\f
+;;;; Useful Cliches
+
+(define (memory->register-transfer offset base target)
+ (case (register-type target)
+ ((GENERAL) (LAP (LD ,target (OFFSET ,offset ,base)) (NOP)))
+ ((FLOAT) (fp-load-doubleword offset base target #T))
+ (else (error "unknown register type" target))))
+
+(define (register->memory-transfer source offset base)
+ (case (register-type source)
+ ((GENERAL) (LAP (ST ,source (OFFSET ,offset ,base))))
+ ((FLOAT) (fp-store-doubleword offset base source))
+ (else (error "unknown register type" source))))
+
+(define (load-constant target constant delay-slot? 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)
+ delay-slot?)))
+
+(define (deposit-type-address type source target)
+ (deposit-type-datum (fix:xor (quotient #x10 type-scale-factor) 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
+ (XORR ,target ,alias ,source)))))
+
+(define (non-pointer->literal constant)
+ (make-non-pointer-literal (object-type constant)
+ (careful-object-datum constant)))
+
+(define-integrable (make-non-pointer-literal type datum)
+ (+ (* type (expt 2 scheme-datum-width)) datum))
+
+(define-integrable (deposit-type type-num target-reg)
+ (if (= target-reg regnum:assembler-temp)
+ (error "deposit-type: into register 1"))
+ (LAP (ANDR ,target-reg ,target-reg ,regnum:address-mask)
+ ,@(put-type type-num target-reg)))
+
+(define-integrable (put-type type-num target-reg)
+ ; Assumes that target-reg has 0 in type bits
+ (LAP (SETHI ,regnum:assembler-temp ,(* type-num #x4000000))
+ (ORR ,target-reg ,regnum:assembler-temp ,target-reg)))
+
+\f
+;;;; Regularized Machine Instructions
+
+(define (adjusted:high n)
+ (let ((n (->unsigned n)))
+ (if (< (remainder n #x10000) #x8000)
+ (quotient n #x10000)
+ (+ (quotient n #x10000) 1))))
+
+(define (adjusted:low n)
+ (let ((remainder (remainder (->unsigned n) #x10000)))
+ (if (< remainder #x8000)
+ remainder
+ (- remainder #x10000))))
+
+(define (low-bits offset)
+ (let ((bits (signed-integer->bit-string 32 offset)))
+ (bit-substring bits 0 10)))
+
+(define (high-bits offset)
+ (let ((bits (signed-integer->bit-string 32 offset)))
+ (bit-substring bits 10 32)))
+
+(define-integrable (top-16-bits n)
+ (quotient (->unsigned n) #x10000))
+
+(define-integrable (bottom-16-bits n)
+ (remainder (->unsigned n) #x10000))
+
+(define-integrable (bottom-10-bits n)
+ (remainder (->unsigned n) #x400))
+
+(define-integrable (bottom-13-bits n)
+ (remainder (->unsigned n) #x2000))
+
+(define-integrable (top-22-bits n)
+ (quotient (->unsigned n) #x400))
+
+(define (->unsigned n)
+ (if (negative? n) (+ #x100000000 n) n))
+
+(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-13-bits-signed? value)
+ (<= #x-2000 value #x1fff))
+
+(define-integrable (fits-in-13-bits-unsigned? value)
+ (<= #x0 value #x1fff))
+
+(define-integrable (top-16-bits-only? value)
+ (zero? (bottom-16-bits value)))
+
+(define-integrable (top-22-bits-only? value)
+ (zero? (bottom-10-bits value)))
+
+(define (copy r t)
+ (if (= r t)
+ (LAP)
+ (LAP (ADD ,t 0 ,r))))
+
+(define (fp-copy from to)
+ (if (= to from)
+ (LAP)
+ (let ((to-reg (float-register->fpr to))
+ (from-reg (float-register->fpr from)))
+ (LAP (FMOVS ,to-reg ,from-reg)
+ (FMOVS ,(+ to-reg 1) ,(+ from-reg 1))))))
+
+;; Handled by VARIABLE-WIDTH in instr1.scm
+
+(define (fp-load-doubleword offset base target NOP?)
+ (let* ((least (float-register->fpr target))
+ (most (+ least 1)))
+ (LAP (LDDF ,least (OFFSET ,offset ,base))
+ ,@(if NOP? (LAP (NOP)) (LAP)))))
+
+(define (fp-store-doubleword offset base source)
+ (let* ((least (float-register->fpr source))
+ (most (+ least 1)))
+ (LAP (SDDF ,least (OFFSET ,offset ,base))
+ ,@(if NOP? (LAP (NOP)) (LAP)))))
+\f
+;;;; PC-relative addresses
+
+(define (load-pc-relative target type label delay-slot?)
+ ;; 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
+ ;; two instructions in addition to the LW instruction, while doing a
+ ;; pc-relative LW 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)
+ (if label*
+ (LAP (LD ,target (OFFSET (- ,label ,label*) ,alias))
+ ,@(if delay-slot? (LAP (NOP)) (LAP)))
+ (let ((temporary (standard-temporary!)))
+ (set-typed-label! type label temporary)
+ (LAP ,@(%load-pc-relative-address temporary label)
+ (LD ,target (OFFSET 0 ,temporary))
+ ,@(if delay-slot? (LAP (NOP)) (LAP))))))))
+
+(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.
+ (let ((instructions
+ (with-values (lambda () (get-typed-label type))
+ (lambda (label* alias)
+ (if label*
+ (LAP (ADDI ,target ,alias (- ,label ,label*)))
+ (%load-pc-relative-address target label))))))
+ (set-typed-label! type label target)
+ instructions))
+
+(define (%load-pc-relative-address target label)
+ (let ((label* (generate-label)))
+ (LAP (CALL 4)
+ (LABEL ,label*)
+ (ADDI ,target ,regnum:call-result (- ,label (- ,label* 4))))))
+
+;;; 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))
+ ((pair? (caar entries))
+ (values (cdaar entries) (cadar entries)))
+ (else
+ (loop (cdr entries))))))
+ ((and (pair? (caar entries*))
+ (eq? type (caaar entries*)))
+ (values (cdaar entries*) (cadar entries*)))
+ (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)
+ (let ((register (get-immediate-alias immediate)))
+ (if register
+ (values (LAP) register)
+ (let ((temporary (standard-temporary!)))
+ (set! *register-map*
+ (set-machine-register-label *register-map*
+ temporary
+ immediate))
+ (values (%load-immediate temporary immediate) temporary)))))
+
+(define (get-immediate-alias immediate)
+ (let loop ((entries (register-map-labels *register-map* 'GENERAL)))
+ (cond ((null? entries)
+ false)
+ ((eqv? (caar entries) immediate)
+ (cadar entries))
+ (else
+ (loop (cdr entries))))))
+
+(define (load-immediate target immediate record?)
+ (let ((registers (get-immediate-aliases immediate)))
+ (if (memv target registers)
+ (LAP)
+ (begin
+ (if record?
+ (set! *register-map*
+ (set-machine-register-label *register-map*
+ target
+ immediate)))
+ (if (not (null? registers))
+ (LAP (ADD ,target 0 ,(car registers)))
+ (%load-immediate target immediate))))))
+
+(define (get-immediate-aliases immediate)
+ (let loop ((entries (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)
+ (cond ((top-22-bits-only? immediate)
+ (LAP (SETHI ,target ,immediate)))
+ ((fits-in-13-bits-signed? immediate)
+ (LAP (ORI ,target ,regnum:zero ,(bottom-13-bits immediate))))
+ (else
+ (LAP (SETHI ,target ,immediate)
+ (ORI ,target ,target ,(bottom-10-bits immediate))))))
+
+(define (add-immediate immediate source target)
+ (if (fits-in-13-bits-signed? immediate)
+ (LAP (ADDI ,target ,source ,immediate))
+ (with-values (lambda () (immediate->register immediate))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ (ADDU ,target ,source ,alias))))))
+\f
+;;;; Comparisons
+
+(define (compare-immediate comp immediate source)
+ ; Branch if immediate <comp> source
+ (let ((cc (invert-condition-noncommutative comp)))
+ ;; This machine does register <op> immediate; you can
+ ;; now think of cc in this way
+ (if (zero? immediate)
+ (begin
+ (branch-generator! cc
+ `(BE) `(BL) `(BG)
+ `(BNE) `(BGE) `(BLE))
+ (LAP (SUBCCI 0 ,source 0)))
+ (with-values (lambda () (immediate->register immediate))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ ,@(compare comp alias source)))))))
+
+(define (compare condition r1 r2)
+ ; Branch if r1 <cc> r2
+ (if (= r1 r2)
+ (let ((branch
+ (lambda (label) (LAP (BA (@PCR ,label)) (NOP))))
+ (dont-branch
+ (lambda (label) label (LAP))))
+ (if (memq condition '(< > <>))
+ (set-current-branches! dont-branch branch)
+ (set-current-branches! branch dont-branch))
+ (LAP (SUBCC 0 ,r1 ,r2)))
+ (begin
+ (branch-generator! condition
+ `(BE) `(BL) `(BG) `(BNE) `(BGE) `(BLE))
+ (LAP (SUBCC 0 ,r1 ,r2)))))
+
+(define (branch-generator! cc = < > <> >= <=)
+ (let ((forward
+ (case cc
+ ((=) =) ((<) <) ((>) >)
+ ((<>) <>) ((>=) >=) ((<=) <=)))
+ (inverse
+ (case cc
+ ((=) <>) ((<) >=) ((>) <=)
+ ((<>) =) ((>=) <) ((<=) >))))
+ (set-current-branches!
+ (lambda (label)
+ (LAP (,@forward (@PCR ,label)) (NOP)))
+ (lambda (label)
+ (LAP (,@inverse (@PCR ,label)) (NOP))))))
+
+(define (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 (SRL ,target ,source ,(- 32 scheme-type-width))))
+
+(define-integrable (object->datum source target)
+ ; Zero out the type field; don't put in the quad bits
+ (LAP (ANDR ,target ,source ,regnum:address-mask)))
+
+(define (object->address source target)
+ ; Drop in the segment bits
+ (LAP (ANDR ,target ,source ,regnum:address-mask)
+ (ADD ,target ,regnum:quad-bits ,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 (standard-move-to-target! source target)
+ (move-to-alias-register! source (register-type source) target))
+
+(define (standard-move-to-temporary! source)
+ (move-to-temporary-register! source (register-type source)))
+
+(define (register-expression expression)
+ (case (rtl:expression-type expression)
+ ((REGISTER)
+ (rtl:register-number expression))
+ ((CONSTANT)
+ (let ((object (rtl:constant-value expression)))
+ (and (zero? (object-type object))
+ (zero? (object-datum object))
+ 0)))
+ ((CONS-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))))
+ 0))
+ (else false)))
+\f
+(define (define-arithmetic-method operator methods method)
+ (let ((entry (assq operator (cdr methods))))
+ (if entry
+ (set-cdr! entry method)
+ (set-cdr! methods (cons (cons operator method) (cdr methods)))))
+ operator)
+
+(define (lookup-arithmetic-method operator methods)
+ (cdr (or (assq operator (cdr methods))
+ (error "Unknown operator" operator))))
+
+(define-integrable (ea/mode ea) (car ea))
+(define-integrable (register-ea/register ea) (cadr ea))
+(define-integrable (offset-ea/offset ea) (cadr ea))
+(define-integrable (offset-ea/register ea) (caddr ea))
+
+(define (pseudo-register-displacement register)
+ ;; Register block consists of 16 4-byte registers followed by 256
+ ;; 8-byte temporaries.
+ (+ (* 4 16) (* 8 (register-renumber register))))
+
+(define-integrable (float-register->fpr register)
+ ;; Float registers are represented by 32 through 47 in the RTL,
+ ;; corresponding to even registers 0 through 30 in the machine.
+ (- register 32))
+
+(define-integrable (fpr->float-register register)
+ (+ register 32))
+
+(define-integrable reg:memtop
+ (INST-EA (OFFSET #x0000 ,regnum:regs-pointer)))
+
+(define-integrable reg:environment
+ (INST-EA (OFFSET #x000C ,regnum:regs-pointer)))
+
+(define-integrable reg:lexpr-primitive-arity
+ (INST-EA (OFFSET #x001C ,regnum:regs-pointer)))
+
+(define-integrable reg:closure-limit
+ (INST-EA (OFFSET #x0024 ,regnum:regs-pointer)))
+
+(define-integrable reg:stack-guard
+ (INST-EA (OFFSET #x002C ,regnum:regs-pointer)))
+
+(define (lap:make-label-statement label)
+ (INST (LABEL ,label)))
+
+(define (lap:make-unconditional-branch label)
+ (LAP (BA (@PCR ,label))
+ (NOP)))
+
+(define (lap:make-entry-point label block-start-label)
+ block-start-label
+ (LAP (ENTRY-POINT ,label)
+ ,@(make-external-label expression-code-word label)))
+\f
+;;;; Codes and Hooks
+
+(let-syntax ((define-codes
+ (macro (start . names)
+ (define (loop names index)
+ (if (null? names)
+ '()
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'CODE:COMPILER-
+ (car names))
+ ,index)
+ (loop (cdr names) (1+ index)))))
+ `(BEGIN ,@(loop names start)))))
+ (define-codes #x012
+ primitive-apply primitive-lexpr-apply
+ apply error lexpr-apply link
+ interrupt-closure interrupt-dlink interrupt-procedure
+ interrupt-continuation interrupt-ic-procedure
+ assignment-trap cache-reference-apply
+ reference-trap safe-reference-trap unassigned?-trap
+ -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
+ access lookup safe-lookup unassigned? unbound?
+ set! define lookup-apply))
+
+(define-integrable (link-to-interface code)
+ ;; Jump to link-to-interface with link in C_arg1
+ (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -4)
+ (JALR ,regnum:first-arg ,regnum:assembler-temp)
+ (ADDI ,regnum:interface-index 0 ,(* 4 code))))
+
+(define-integrable (link-to-trampoline code)
+ ;; Jump, with link in 31, to trampoline_to_interface
+ ;; Jump, with link in C_arg1 to scheme-to-interface
+ (LAP (JALR ,regnum:first-arg ,regnum:scheme-to-interface)
+ (ADDI ,regnum:interface-index 0 ,(* 4 code))))
+
+(define-integrable (invoke-interface code)
+ ;; Jump to scheme-to-interface
+ (LAP (JALR ,regnum:assembler-temp ,regnum:scheme-to-interface)
+ (ADDI ,regnum:interface-index 0 ,(* 4 code))))
+
+(define (load-interface-args! first second third fourth)
+ (let ((clear-regs
+ (apply clear-registers!
+ (append (if first (list regnum:first-arg) '())
+ (if second (list regnum:second-arg) '())
+ (if third (list regnum:third-arg) '())
+ (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!)))))
+
+(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))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/lapopt.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Optimizer for MIPS.
+
+(declare (usual-integrations))
+\f
+(define (optimize-linear-lap instructions)
+ instructions)
+
+#|
+(define (optimize-linear-lap instructions)
+ ;; Find occurrences of LW/LBU/LWC1 followed by NOP, and delete the
+ ;; NOP if the instruction following it has no reference to the
+ ;; target register of the load.
+
+ ;; **** This is pretty fragile. ****
+ (letrec
+ ((find-load
+ (lambda (instructions)
+ (cond ((null? instructions) '())
+ ((and (pair? (car instructions))
+ (or (eq? 'LW (caar instructions))
+ (eq? 'LBU (caar instructions))
+ (eq? 'LWC1 (caar instructions))))
+ instructions)
+ (else (find-load (cdr instructions))))))
+ (get-next
+ (lambda (instructions)
+ (let ((instructions (cdr instructions)))
+ (cond ((null? instructions) '())
+ ((or (not (pair? (car instructions)))
+ (eq? 'LABEL (caar instructions))
+ (eq? 'COMMENT (caar instructions)))
+ (get-next instructions))
+ (else instructions)))))
+ (refers-to-register?
+ (lambda (instruction register)
+ (let loop ((x instruction))
+ (if (pair? x)
+ (or (loop (car x))
+ (loop (cdr x)))
+ (eqv? register x))))))
+ (let loop ((instructions instructions))
+ (let ((first (find-load instructions)))
+ (if (not (null? first))
+ (let ((second (get-next first)))
+ (if (not (null? second))
+ (let ((third (get-next second)))
+ (if (not (null? third))
+ (if (and (equal? '(NOP) (car second))
+ ;; This is a crude way to test for a
+ ;; reference to the target register
+ ;; -- it will sometimes incorrectly
+ ;; say that there is a reference, but
+ ;; it will never incorrectly say that
+ ;; there is no reference.
+ (not (refers-to-register? (car third)
+ (cadar first)))
+ (or (not (and (eq? 'LWC1 (caar first))
+ (odd? (cadar first))))
+ (not (refers-to-register?
+ (car third)
+ (- (cadar first) 1)))))
+ (begin
+ (let loop ((this (cdr first)) (prev first))
+ (if (eq? second this)
+ (set-cdr! prev (cdr this))
+ (loop (cdr this) this)))
+ (loop (if (equal? '(NOP) (car third))
+ first
+ third)))
+ (loop second))))))))))
+ instructions)
+|#
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/machin.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Machine Model for SPARC
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;;; Architecture Parameters
+
+(define use-pre/post-increment? false)
+(define endianness 'BIG)
+(define-integrable addressing-granularity 8)
+(define-integrable scheme-object-width 32)
+(define-integrable scheme-type-width 6) ;or 8
+(define-integrable type-scale-factor (expt 2 (- 8 scheme-type-width)))
+
+(define-integrable scheme-datum-width
+ (- scheme-object-width scheme-type-width))
+
+(define-integrable flonum-size 2)
+(define-integrable float-alignment 64)
+
+;;; It is currently required that both packed characters and objects
+;;; be integrable numbers of address units. Furthermore, the number
+;;; of address units per object must be an integral multiple of the
+;;; number of address units per character. This will cause problems
+;;; on a machine that is word addressed, in which case we will have to
+;;; rethink the character addressing strategy.
+
+(define-integrable address-units-per-object
+ (quotient scheme-object-width addressing-granularity))
+
+(define-integrable address-units-per-packed-char 1)
+
+(define-integrable signed-fixnum/upper-limit (expt 2 (-1+ scheme-datum-width)))
+(define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit))
+(define-integrable unsigned-fixnum/upper-limit (* 2 signed-fixnum/upper-limit))
+
+(define-integrable (stack->memory-offset offset) offset)
+(define-integrable ic-block-first-parameter-offset 2)
+(define-integrable execute-cache-size 3) ; Long words per UUO link slot
+(define-integrable closure-entry-size
+ ;; Long words in a single closure entry:
+ ;; Format + GC offset word
+ ;; SETHI
+ ;; JALR/JAL
+ ;; ADDI
+ 4)
+
+;; 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)))
+
+;; Like the above, but from the start of the complete closure object,
+;; viewed as a vector, and including the header word.
+
+(define (closure-object-first-offset nentries)
+ (case nentries
+ ((0)
+ ;; Vector header only
+ 1)
+ ((1)
+ ;; Manifest closure header followed by single entry point
+ (+ 1 closure-entry-size))
+ (else
+ ;; Manifest closure header, number of entries, then entries.
+ (+ 1 1 (* closure-entry-size nentries)))))
+
+;; Bump from one entry point to another -- distance in BYTES
+
+(define (closure-entry-distance nentries entry entry*)
+ nentries ; ignored
+ (* (* closure-entry-size 4) (- entry* entry)))
+
+;; Bump to the canonical entry point. On a RISC (which forces
+;; longword alignment for entry points anyway) there is no need to
+;; canonicalize.
+
+(define (closure-environment-adjustment nentries entry)
+ nentries entry ; ignored
+ 0)
+\f
+;;;; Machine Registers
+
+(define-integrable g0 0)
+(define-integrable g1 1)
+(define-integrable g2 2)
+(define-integrable g3 3)
+(define-integrable g4 4)
+(define-integrable g5 5)
+(define-integrable g6 6)
+(define-integrable g7 7)
+(define-integrable g8 8)
+(define-integrable g9 9)
+(define-integrable g10 10)
+(define-integrable g11 11)
+(define-integrable g12 12)
+(define-integrable g13 13)
+(define-integrable g14 14)
+(define-integrable g15 15)
+(define-integrable g16 16)
+(define-integrable g17 17)
+(define-integrable g18 18)
+(define-integrable g19 19)
+(define-integrable g20 20)
+(define-integrable g21 21)
+(define-integrable g22 22)
+(define-integrable g23 23)
+(define-integrable g24 24)
+(define-integrable g25 25)
+(define-integrable g26 26)
+(define-integrable g27 27)
+(define-integrable g28 28)
+(define-integrable g29 29)
+(define-integrable g30 30)
+(define-integrable g31 31)
+
+;; Floating point general registers -- the odd numbered ones are
+;; only used when transferring to/from the CPU
+(define-integrable fp0 32)
+(define-integrable fp1 33)
+(define-integrable fp2 34)
+(define-integrable fp3 35)
+(define-integrable fp4 36)
+(define-integrable fp5 37)
+(define-integrable fp6 38)
+(define-integrable fp7 39)
+(define-integrable fp8 40)
+(define-integrable fp9 41)
+(define-integrable fp10 42)
+(define-integrable fp11 43)
+(define-integrable fp12 44)
+(define-integrable fp13 45)
+(define-integrable fp14 46)
+(define-integrable fp15 47)
+(define-integrable fp16 48)
+(define-integrable fp17 49)
+(define-integrable fp18 50)
+(define-integrable fp19 51)
+(define-integrable fp20 52)
+(define-integrable fp21 53)
+(define-integrable fp22 54)
+(define-integrable fp23 55)
+(define-integrable fp24 56)
+(define-integrable fp25 57)
+(define-integrable fp26 58)
+(define-integrable fp27 59)
+(define-integrable fp28 60)
+(define-integrable fp29 61)
+(define-integrable fp30 62)
+(define-integrable fp31 63)
+
+(define-integrable number-of-machine-registers 64)
+(define-integrable number-of-temporary-registers 256)
+\f
+;;; Fixed-use registers for Scheme compiled code.
+(define-integrable regnum:return-value g16)
+(define-integrable regnum:stack-pointer g17)
+(define-integrable regnum:memtop g18)
+(define-integrable regnum:free g19)
+(define-integrable regnum:scheme-to-interface g20)
+(define-integrable regnum:dynamic-link g21)
+(define-integrable regnum:closure-free g22)
+(define-integrable regnum:address-mask g25)
+(define-integrable regnum:regs-pointer g26)
+(define-integrable regnum:quad-bits g27)
+(define-integrable regnum:closure-hook g28)
+(define-integrable regnum:interface-index g13)
+
+;;; Fixed-use registers due to architecture or OS calling conventions.
+(define-integrable regnum:zero g0)
+(define-integrable regnum:assembler-temp g1)
+(define-integrable regnum:C-return-receive-value g8)
+(define-integrable regnum:C-return-send-value g24)
+(define-integrable regnum:C-stack-pointer g14)
+(define-integrable regnum:first-arg g8)
+(define-integrable regnum:second-arg g9)
+(define-integrable regnum:third-arg g10)
+(define-integrable regnum:fourth-arg g11)
+(define-integrable regnum:fifth-arg g12)
+(define-integrable regnum:sixth-arg g13)
+(define-integrable regnum:reserved-global-1 g2)
+(define-integrable regnum:reserved-global-2 g3)
+(define-integrable regnum:reserved-global-3 g4)
+(define-integrable regnum:reserved-global-4 g5)
+(define-integrable regnum:reserved-global-5 g6)
+(define-integrable regnum:reserved-global-6 g7)
+(define-integrable regnum:linkage g31)
+(define-integrable regnum:call-result g15)
+
+(define address-regs
+ (list regnum:stack-pointer regnum:memtop regnum:free regnum:dynamic-link
+ regnum:linkage))
+
+(define object-regs
+ (list regnum:return-value regnum:C-return-send-value))
+
+(define immediate-regs
+ (list regnum:address-mask regnum:quad-bits))
+
+(define unboxed-regs
+ (list regnum:scheme-to-interface
+ regnum:regs-pointer regnum:assembler-temp
+ regnum:reserved-global-4
+ regnum:reserved-global-5
+ regnum:reserved-global-6
+ regnum:C-stack-pointer
+ ))
+
+(define machine-register-value-class
+ (lambda (register)
+ (cond ((member register address-regs) value-class=address)
+ ((member register object-regs) value-class=object)
+ ((member register immediate-regs) value-class=immediate)
+ ((member register unboxed-regs) value-class=unboxed)
+ ((<= g0 register g31) value-class=word)
+ ((<= fp0 register fp31) value-class=float)
+ (else (error "illegal machine register" register)))))
+
+(define-integrable (machine-register-known-value register)
+ register ;ignore
+ false)
+\f
+;;;; Interpreter Registers
+
+(define-integrable (interpreter-free-pointer)
+ (rtl:make-machine-register regnum:free))
+
+(define (interpreter-free-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:free)))
+
+(define-integrable (interpreter-regs-pointer)
+ (rtl:make-machine-register regnum:regs-pointer))
+
+(define (interpreter-regs-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:regs-pointer)))
+
+(define-integrable (interpreter-value-register)
+ (rtl:make-machine-register regnum:return-value))
+
+(define (interpreter-value-register? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:return-value)))
+
+(define-integrable (interpreter-stack-pointer)
+ (rtl:make-machine-register regnum:stack-pointer))
+
+(define (interpreter-stack-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:stack-pointer)))
+
+(define-integrable (interpreter-dynamic-link)
+ (rtl:make-machine-register regnum:dynamic-link))
+
+(define (interpreter-dynamic-link? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:dynamic-link)))
+
+(define-integrable (interpreter-environment-register)
+ (rtl:make-offset (interpreter-regs-pointer) 3))
+
+(define (interpreter-environment-register? expression)
+ (and (rtl:offset? expression)
+ (interpreter-regs-pointer? (rtl:offset-base expression))
+ (= 3 (rtl:offset-number expression))))
+
+(define-integrable (interpreter-register:access)
+ (rtl:make-machine-register regnum:C-return-send-value))
+
+(define-integrable (interpreter-register:cache-reference)
+ (rtl:make-machine-register regnum:C-return-send-value))
+
+(define-integrable (interpreter-register:cache-unassigned?)
+ (rtl:make-machine-register regnum:C-return-send-value))
+
+(define-integrable (interpreter-register:lookup)
+ (rtl:make-machine-register regnum:C-return-send-value))
+
+(define-integrable (interpreter-register:unassigned?)
+ (rtl:make-machine-register regnum:C-return-send-value))
+
+(define-integrable (interpreter-register:unbound?)
+ (rtl:make-machine-register regnum:C-return-send-value))
+\f
+;;;; RTL Registers, Constants, and Primitives
+
+(define (rtl:machine-register? rtl-register)
+ (case rtl-register
+ ((STACK-POINTER)
+ (interpreter-stack-pointer))
+ ((DYNAMIC-LINK)
+ (interpreter-dynamic-link))
+ ((VALUE)
+ (interpreter-value-register))
+ ((INTERPRETER-CALL-RESULT:ACCESS)
+ (interpreter-register:access))
+ ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
+ (interpreter-register:cache-reference))
+ ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
+ (interpreter-register:cache-unassigned?))
+ ((INTERPRETER-CALL-RESULT:LOOKUP)
+ (interpreter-register:lookup))
+ ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
+ (interpreter-register:unassigned?))
+ ((INTERPRETER-CALL-RESULT:UNBOUND?)
+ (interpreter-register:unbound?))
+ (else false)))
+
+(define (rtl:interpreter-register? rtl-register)
+ (case rtl-register
+ ((MEMORY-TOP) 0)
+ ((STACK-GUARD) 1)
+ ((ENVIRONMENT) 3)
+ ((TEMPORARY) 4)
+ (else false)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown register type" locative)))
+
+(define (rtl:constant-cost expression)
+ ;; Magic numbers.
+ (let ((if-integer
+ (lambda (value)
+ (cond ((zero? value) 1)
+ ((or (fits-in-16-bits-signed? value)
+ (fits-in-16-bits-unsigned? value)
+ (top-16-bits-only? value))
+ 2)
+ (else 3)))))
+ (let ((if-synthesized-constant
+ (lambda (type datum)
+ (if-integer (make-non-pointer-literal type datum)))))
+ (case (rtl:expression-type expression)
+ ((CONSTANT)
+ (let ((value (rtl:constant-value expression)))
+ (if (non-pointer-object? value)
+ (if-synthesized-constant (object-type value)
+ (object-datum value))
+ 3)))
+ ((MACHINE-CONSTANT)
+ (if-integer (rtl:machine-constant-value expression)))
+ ((ENTRY:PROCEDURE
+ ENTRY:CONTINUATION
+ ASSIGNMENT-CACHE
+ VARIABLE-CACHE
+ OFFSET-ADDRESS)
+ 3)
+ ((CONS-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)
+
+(set! compiler:open-code-primitives? #f)
+
+(define compiler:primitives-with-no-open-coding
+ '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER
+ FIXNUM-NOT FIXNUM-AND FIXNUM-ANDC FIXNUM-OR FIXNUM-XOR FIXNUM-LSH
+ INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER
+ FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS
+ FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND
+ FLONUM-REMAINDER FLONUM-SQRT))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/make.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1988-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler: System Construction
+
+(declare (usual-integrations))
+
+(package/system-loader "comp" '() 'QUERY)
+(for-each (lambda (name)
+ ((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
+ '((COMPILER MACROS)
+ (COMPILER DECLARATIONS)))
+(set! (access endianness (->environment '(COMPILER))) 'BIG)
+(add-system! (make-system "Liar (SPARC)" 4 87 '()))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rgspcm.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+$MC68020-Header: /scheme/compiler/bobcat/RCS/rgspcm.scm,v 4.2 1991/05/06 23:17:03 jinx Exp $
+
+Copyright (c) 1987-1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Generation: Special primitive combinations. Spectrum version.
+
+(declare (usual-integrations))
+\f
+(define (define-special-primitive-handler name handler)
+ (let ((primitive (make-primitive-procedure name true)))
+ (let ((entry (assq primitive special-primitive-handlers)))
+ (if entry
+ (set-cdr! entry handler)
+ (set! special-primitive-handlers
+ (cons (cons primitive handler)
+ special-primitive-handlers)))))
+ name)
+
+(define (special-primitive-handler primitive)
+ (let ((entry (assq primitive special-primitive-handlers)))
+ (and entry
+ (cdr entry))))
+
+(define special-primitive-handlers
+ '())
+
+(define (define-special-primitive/standard primitive)
+ (define-special-primitive-handler primitive
+ rtl:make-invocation:special-primitive))
+
+(define-special-primitive/standard '&+)
+(define-special-primitive/standard '&-)
+(define-special-primitive/standard '&*)
+(define-special-primitive/standard '&/)
+(define-special-primitive/standard '&=)
+(define-special-primitive/standard '&<)
+(define-special-primitive/standard '&>)
+(define-special-primitive/standard '1+)
+(define-special-primitive/standard '-1+)
+(define-special-primitive/standard 'zero?)
+(define-special-primitive/standard 'positive?)
+(define-special-primitive/standard 'negative?)
+(define-special-primitive/standard 'quotient)
+(define-special-primitive/standard 'remainder)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rules1.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1989-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Data Transfers
+
+(declare (usual-integrations))
+\f
+;;;; Simple Operations
+
+;;; All assignments to pseudo registers are required to delete the
+;;; dead registers BEFORE performing the assignment. However, it is
+;;; necessary to derive the effective address of the source
+;;; expression(s) before deleting the dead registers. Otherwise any
+;;; source expression containing dead registers might refer to aliases
+;;; which have been reused.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
+ (standard-move-to-target! source target)
+ (LAP))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (let* ((type (standard-move-to-temporary! type))
+ (target (standard-move-to-target! datum target)))
+ (LAP (SLL ,type ,type ,(- 32 scheme-type-width))
+ (ANDR ,target ,target ,regnum:address-mask)
+ (ORR ,target ,type ,target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-NON-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (let* ((type (standard-move-to-temporary! type))
+ (target (standard-move-to-target! datum target)))
+ (LAP (SLL ,type ,type ,(- 32 scheme-type-width))
+ (ORR ,target ,type ,target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
+ (let ((target (standard-move-to-target! source target)))
+ (deposit-type type target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (deposit-type type source))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (standard-unary-conversion source target object->type))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+ (standard-unary-conversion source target object->datum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (standard-unary-conversion source target object->address))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (add-immediate (* 4 offset) source target))))
+
+(define-rule statement
+ (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 #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)
+ true))
+
+(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)
+ true))
+
+(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)
+ (ADDI ,target ,temporary 0)
+ ,@(deposit-type type target))))
+\f
+;;;; Transfers from memory
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
+ (standard-unary-conversion address target
+ (lambda (address target)
+ (LAP (LD ,target (OFFSET ,(* 4 offset) ,address))
+ (NOP)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 17) 1))
+ (LAP (LD ,(standard-target! target) (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)))
+
+;;;; Transfers to memory
+
+(define-rule statement
+ ;; store an object in memory
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (? source register-expression))
+ (QUALIFIER (word-register? source))
+ (LAP (ST ,(standard-source! source)
+ (OFFSET ,(* 4 offset) ,(standard-source! address)))))
+
+(define-rule statement
+ ;; Push an object register on the heap
+ (ASSIGN (POST-INCREMENT (REGISTER 19) 1)
+ (? source register-expression))
+ (QUALIFIER (word-register? source))
+ (LAP (ST ,(standard-source! source) (OFFSET 0 ,regnum:free))
+ (ADDI ,regnum:free ,regnum:free 4)))
+
+(define-rule statement
+ ;; Push an object register on the stack
+ (ASSIGN (PRE-INCREMENT (REGISTER 17) -1)
+ (? source register-expression))
+ (QUALIFIER (word-register? source))
+ (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
+ (ST ,(standard-source! source)
+ (OFFSET 0 ,regnum:stack-pointer))))
+
+;; Cheaper, common patterns.
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (MACHINE-CONSTANT 0))
+ (LAP (ST 0 (OFFSET ,(* 4 offset) ,(standard-source! address)))))
+
+(define-rule statement
+ ; Push NIL (or whatever is represented by a machine 0) on heap
+ (ASSIGN (POST-INCREMENT (REGISTER 19) 1) (MACHINE-CONSTANT 0))
+ (LAP (ST 0 (OFFSET 0 ,regnum:free))
+ (ADDI ,regnum:free ,regnum:free 4)))
+
+(define-rule statement
+ ; Ditto, but on stack
+ (ASSIGN (PRE-INCREMENT (REGISTER 17) -1) (MACHINE-CONSTANT 0))
+ (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
+ (ST 0 (OFFSET 0 ,regnum:stack-pointer))))
+\f
+;;;; CHAR->ASCII/BYTE-OFFSET
+
+(define-rule statement
+ ;; load char object from memory and convert to ASCII byte
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
+ (standard-unary-conversion address target
+ (lambda (address target)
+ (LAP (LDUB ,target
+ (OFFSET ,(let ((offset (* 4 offset)))
+ (if (eq? endianness 'LITTLE)
+ offset
+ (+ offset 3)))
+ ,address))
+ (NOP)))))
+
+(define-rule statement
+ ;; load ASCII byte from memory
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET (REGISTER (? address)) (? offset)))
+ (standard-unary-conversion address target
+ (lambda (address target)
+ (LAP (LDUB ,target (OFFSET ,offset ,address))
+ (NOP)))))
+
+(define-rule statement
+ ;; convert char object to ASCII byte
+ ;; Missing optimization: If source is home and this is the last
+ ;; reference (it is dead afterwards), an LB could be done instead of
+ ;; an LW followed by an ANDI. This is unlikely since the value will
+ ;; be home only if we've spilled it, which happens rarely.
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (REGISTER (? source))))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (LAP (ANDI ,target ,source #xFF)))))
+
+(define-rule statement
+ ;; store null byte in memory
+ (ASSIGN (BYTE-OFFSET (REGISTER (? source)) (? offset))
+ (CHAR->ASCII (CONSTANT #\NUL)))
+ (LAP (STB 0 (OFFSET ,offset ,(standard-source! source)))))
+
+(define-rule statement
+ ;; store ASCII byte in memory
+ (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (REGISTER (? source)))
+ (LAP (STB ,(standard-source! source)
+ (OFFSET ,offset ,(standard-source! address)))))
+
+(define-rule statement
+ ;; convert char object to ASCII byte and store it in memory
+ ;; register + byte offset <- contents of register (clear top bits)
+ (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+ (CHAR->ASCII (REGISTER (? source))))
+ (LAP (STB ,(standard-source! source)
+ (OFFSET ,offset ,(standard-source! address)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rules2.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1988-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Predicates
+
+(declare (usual-integrations))
+\f
+(define-rule predicate
+ ;; test for two registers EQ?
+ (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
+ (compare '= (standard-source! source1) (standard-source! source2)))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
+ (eq-test/constant*register constant register))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
+ (eq-test/constant*register constant register))
+
+(define (eq-test/constant*register constant source)
+ (let ((source (standard-source! source)))
+ (if (non-pointer-object? constant)
+ (compare-immediate '= (non-pointer->literal constant) source)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-pc-relative temp
+ 'CONSTANT (constant->label constant)
+ #T)
+ ,@(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-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rules3.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Invocations
+
+(define-rule statement
+ (POP-RETURN)
+ (pop-return))
+
+(define (pop-return)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(clear-map!)
+ (LD ,temp (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
+ ,@(object->address temp temp)
+ (JR ,temp)
+ (NOP)))) ; DELAY SLOT
+
+(define-rule statement
+ (INVOCATION:APPLY (? frame-size) (? continuation))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ ,@(load-immediate regnum:second-arg frame-size #F)
+ (LD ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
+ ,@(invoke-interface code:compiler-apply)))
+
+(define-rule statement
+ (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+ frame-size continuation ;ignore
+ (LAP ,@(clear-map!)
+ (BA (@PCR ,label))
+ (NOP))) ; DELAY SLOT
+
+(define-rule statement
+ (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
+ frame-size continuation ;ignore
+ ;; It expects the procedure at the top of the stack
+ (pop-return))
+
+(define-rule statement
+ (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
+ continuation ;ignore
+ (let* ((clear-second-arg (clear-registers! regnum:first-arg))
+ (load-second-arg
+ (load-pc-relative-address regnum:first-arg 'CODE label)))
+ (LAP ,@clear-second-arg
+ ,@load-second-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 second-arg
+ (LAP ,@(clear-map!)
+ (LD ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
+ ,@(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!)
+ (BA (@PCR ,(free-uuo-link-label name frame-size)))
+ (NOP)))
+
+(define-rule statement
+ (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ (BA (@PCR ,(global-uuo-link-label name frame-size)))
+ (NOP))) ; DELAY SLOT
+
+(define-rule statement
+ (INVOCATION:CACHE-REFERENCE (? frame-size)
+ (? continuation)
+ (? extension register-expression))
+ continuation ;ignore
+ (let* ((clear-third-arg (clear-registers! regnum:second-arg))
+ (load-third-arg
+ (load-pc-relative-address regnum:second-arg 'CODE *block-label*)))
+ (LAP ,@clear-third-arg
+ ,@load-third-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 #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-second-arg (clear-registers! regnum:second-arg))
+ (load-second-arg
+ (load-pc-relative regnum:first-arg
+ 'CONSTANT
+ (constant->label primitive)
+ false)))
+ (LAP ,@clear-second-arg
+ ,@load-second-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)
+ (ST ,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 3))
+ (LAP))
+
+(define-rule statement
+ ;; Move <frame-size> words back to dynamic link marker
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 11))
+ (generate/move-frame-up frame-size
+ (lambda (reg) (LAP (ADD ,reg 0 ,regnum:dynamic-link)))))
+
+(define-rule statement
+ ;; Move <frame-size> words back to dynamic link marker
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? dest)))
+ (generate/move-frame-up frame-size
+ (lambda (reg) (LAP (ADD ,reg 0 ,dest)))))
+
+(define-rule statement
+ ;; Move <frame-size> words back to SP+offset
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
+ (OFFSET-ADDRESS (REGISTER 3) (? offset)))
+ (let ((how-far (* 4 (- offset frame-size))))
+ (cond ((zero? how-far)
+ (LAP))
+ ((negative? how-far)
+ (error "invocation-prefix:move-frame-up: bad specs"
+ frame-size offset))
+ ((zero? frame-size)
+ (add-immediate how-far regnum:stack-pointer regnum:stack-pointer))
+ ((= frame-size 1)
+ (let ((temp (standard-temporary!)))
+ (LAP (LD ,temp (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far)
+ (STW ,temp (OFFSET 0 ,regnum:stack-pointer)))))
+ ((= frame-size 2)
+ (let ((temp1 (standard-temporary!))
+ (temp2 (standard-temporary!)))
+ (LAP (LD ,temp1 (OFFSET 0 ,regnum:stack-pointer))
+ (LD ,temp2 (OFFSET 4 ,regnum:stack-pointer))
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far)
+ (ST ,temp1 (OFFSET 0 ,regnum:stack-pointer))
+ (ST ,temp2 (OFFSET 4 ,regnum:stack-pointer)))))
+ (else
+ (generate/move-frame-up frame-size
+ (lambda (reg)
+ (add-immediate (* 4 offset) regnum:stack-pointer reg)))))))
+
+(define-rule statement
+ ;; Move <frame-size> words back to base virtual register + offset
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (? offset)))
+ (QUALIFIER (not (= base 3)))
+ (generate/move-frame-up frame-size
+ (lambda (reg)
+ (add-immediate (* 4 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 11))
+ (if (and (zero? frame-size)
+ (= source regnum:stack-pointer))
+ (LAP)
+ (let ((env-reg (standard-move-to-temporary! source))
+ (label (generate-label)))
+ (LAP (SLTU ,regnum:assembler-temp ,env-reg ,regnum:dynamic-link)
+ (BNE 0 ,regnum:assembler-temp (@PCR ,label))
+ (NOP)
+ (ADD ,env-reg 0 ,regnum:dynamic-link)
+ (LABEL ,label)
+ ,@(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 (LD ,temp (OFFSET 0 ,regnum:stack-pointer))
+ (ADDI ,destination ,destination -4)
+ (ST ,temp (OFFSET 0 ,destination)))))
+ (else
+ (let ((from (standard-temporary!))
+ (temp1 (standard-temporary!))
+ (temp2 (standard-temporary!)))
+ (LAP ,@(add-immediate (* 4 frame-size) regnum:stack-pointer from)
+ ,@(if (<= frame-size 3)
+ ;; This code can handle any number > 1
+ ;; (handled above), but we restrict it to 3
+ ;; for space reasons.
+ (let loop ((n frame-size))
+ (case n
+ ((0)
+ (LAP))
+ ((3)
+ (let ((temp3 (standard-temporary!)))
+ (LAP (LD ,temp1 (OFFSET -4 ,from))
+ (LD ,temp2 (OFFSET -8 ,from))
+ (LD ,temp3 (OFFSET -12 ,from))
+ (ADDI ,from ,from -12)
+ (ST ,temp1 (OFFSET -4 ,destination))
+ (ST ,temp2 (OFFSET -8 ,destination))
+ (ST ,temp3 (OFFSET -12 ,destination))
+ (ADDI ,destination ,destination -12))))
+ (else
+ (LAP (LD ,temp1 (OFFSET -4 ,from))
+ (LD ,temp2 (OFFSET -8 ,from))
+ (ADDI ,from ,from -8)
+ (ST ,temp1 (OFFSET -4 ,destination))
+ (ST ,temp2 (OFFSET -8 ,destination))
+ (ADDI ,destination ,destination -8)
+ ,@(loop (- n 2))))))
+ (let ((label (generate-label)))
+ (LAP ,@(load-immediate temp2 frame-size #F)
+ (LABEL ,label)
+ (LD ,temp1 (OFFSET -4 ,from))
+ (ADDI ,from ,from -4)
+ (ADDI ,temp2 ,temp2 -1)
+ (ADDI ,destination ,destination -4)
+ (BNE ,temp2 0 (@PCR ,label))
+ (ST ,temp1 (OFFSET 0 ,destination)))))))))
+ (ADD ,regnum:stack-pointer 0 ,destination)))
+\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)
+ (ADD ,regnum:third-arg 0 ,regnum:dynamic-link)
+ ,@(link-to-interface code:compiler-interrupt-dlink)
+ ,@(make-external-label code-word label)
+ ,@(interrupt-check gc-label))))
+
+(define (interrupt-check gc-label)
+ (LAP (SUBCC ,regnum:assembler-temp ,regnum:memtop ,regnum:free)
+ (BGE (@PCR ,gc-label))
+ (LD ,regnum:memtop ,reg:memtop)
+ ))
+
+(define-rule statement
+ (CONTINUATION-ENTRY (? internal-label))
+ (make-external-label (continuation-code-word internal-label)
+ internal-label))
+
+(define-rule statement
+ (CONTINUATION-HEADER (? internal-label))
+ (simple-procedure-header (continuation-code-word internal-label)
+ internal-label
+ code:compiler-interrupt-continuation))
+
+(define-rule statement
+ (IC-PROCEDURE-HEADER (? internal-label))
+ (let ((procedure (label->object internal-label)))
+ (let ((external-label (rtl-procedure/external-label procedure)))
+ (LAP (ENTRY-POINT ,external-label)
+ (EQUATE ,external-label ,internal-label)
+ ,@(simple-procedure-header expression-code-word
+ internal-label
+ code:compiler-interrupt-ic-procedure)))))
+
+(define-rule statement
+ (OPEN-PROCEDURE-HEADER (? internal-label))
+ (let ((rtl-proc (label->object internal-label)))
+ (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
+ ,@((if (rtl-procedure/dynamic-link? rtl-proc)
+ dlink-procedure-header
+ (lambda (code-word label)
+ (simple-procedure-header code-word label
+ code:compiler-interrupt-procedure)))
+ (internal-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 -- non-RISCs only
+ (if (zero? nentries)
+ (error "Closure header for closure with no entries!"
+ internal-label))
+ (let ((rtl-proc (label->object internal-label)))
+ (let ((gc-label (generate-label))
+ (external-label (rtl-procedure/external-label rtl-proc)))
+ (LAP (LABEL ,gc-label)
+ ,@(invoke-interface code:compiler-interrupt-closure)
+ ,@(make-external-label
+ (internal-procedure-code-word rtl-proc)
+ external-label)
+ (ADDI ,regnum:assembler-temp ,regnum:assembler-temp -12)
+ ;; Code below here corresponds to code and count in cmpint2.h
+ ,@(fluid-let ((*register-map* *register-map*))
+ (let ((temporary (standard-temporary!)))
+ ;; Don't cache type constant here, because it won't be
+ ;; in the register if the closure is entered from the
+ ;; internal label.
+ (LAP
+ (ADDI ,temporary ,regnum:assembler-temp 0)
+ ,@(put-type (ucode-type compiled-entry) temporary)
+ (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
+ (ST ,temporary (OFFSET 0 ,regnum:stack-pointer))
+ (NOP))))
+ (LABEL ,internal-label)
+ ,@(interrupt-check gc-label)))))
+
+(define (build-gc-offset-word offset code-word)
+ (let ((encoded-offset (quotient offset 2)))
+ (if (eq? endianness 'LITTLE)
+ (+ (* encoded-offset #x10000) code-word)
+ (+ (* code-word #x10000) encoded-offset))))
+
+(define (closure-bump-size nentries nvars)
+ (* (* 4 closure-entry-size)
+ (1+ (quotient (+ (+ nvars (-1+ (* closure-entry-size nentries)))
+ (-1+ closure-entry-size))
+ closure-entry-size))))
+
+(define (closure-test-size nentries nvars)
+ (* 4
+ (+ nvars
+ (-1+ (* nentries closure-entry-size)))))
+
+(define (cons-closure target label min max nvars)
+
+ ;; Invoke an out-of-line handler to set up the closure's entry point.
+ ;; Arguments:
+ ;; - C_arg1: "Return address"
+ ;; - C_arg2: Delta from header data to real closure code
+ ;; - C_arg3: Closure size in bytes
+ ;; After jumping to the out of line handler, the return address should
+ ;; point to the header data.
+ ;; Returns closure in regnum:second-arg
+
+ (need-register! regnum:first-arg)
+ (need-register! regnum:second-arg)
+ (need-register! regnum:third-arg)
+ (need-register! regnum:fourth-arg)
+ (let* ((label-arg (generate-label))
+ (dest (standard-target! target)))
+ (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -108)
+ (ADDI ,regnum:second-arg 0 (- ,(rtl-procedure/external-label (label->object label))
+ ,label-arg))
+ (ADDI ,regnum:third-arg 0 ,(+ 20 (* nvars 4)))
+ (JMPL ,regnum:first-arg ,regnum:assembler-temp 0)
+ (ADDI ,regnum:first-arg ,regnum:first-arg 8)
+ (LABEL ,label-arg)
+ (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
+ (+ closure-entry-size nvars)))
+ (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max)))
+ (ADDI ,dest ,regnum:second-arg 0)
+ ))
+ )
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+ (? min) (? max) (? nvars)))
+ (cons-closure target procedure-label min max nvars))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-MULTICLOSURE (? nentries) (? nvars) (? entries)))
+ ;; entries is a vector of all the entry points
+ (case nentries
+ ((0)
+ (let ((dest (standard-target! target))
+ (temp (standard-temporary!)))
+ (LAP (ADD ,dest 0 ,regnum:free)
+ ,@(load-immediate
+ temp
+ (make-non-pointer-literal (ucode-type manifest-vector) nvars)
+ #T)
+ (ST ,temp (OFFSET 0 ,regnum:free))
+ (ADDI ,regnum:free ,regnum:free ,(* 4 (+ nvars 1))))))
+ ((1)
+ (let ((entry (vector-ref entries 0)))
+ (cons-closure target (car entry) (cadr entry) (caddr entry) nvars)))
+ (else
+ (cons-multiclosure target nentries nvars (vector->list entries)))))
+
+(define (cons-multiclosure target nentries nvars entries)
+ ;; Invoke an out-of-line handler to set up the closure's entry points.
+ ;; Arguments:
+ ;; - C_arg1: Linkage address
+ ;; - C_arg2: Number of entries
+ ;; - C_arg3: Number of bytes taken up by closures
+
+ ;; C_arg1 points to a manifest closure header word, followed by
+ ;; nentries two-word structures, followed by the actual
+ ;; instructions to return to.
+ ;; The first word of each descriptor is the format+gc-offset word of
+ ;; the corresponding entry point of the generated closure.
+ ;; The second word is the PC-relative JAL instruction.
+ ;; It is transformed into an absolute instruction by adding the shifted
+ ;; "return address".
+ ;; Returns closure in regnum:second-arg.
+ (rtl-target:=machine-register! target regnum:second-arg)
+ (require-register! regnum:first-arg)
+ (require-register! regnum:second-arg)
+ (require-register! regnum:third-arg)
+ (require-register! regnum:fourth-arg)
+ (let ((label-arg (generate-label))
+ (dest (standard-target! target)))
+ (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -256)
+ (ADDI ,regnum:second-arg 0 ,nentries)
+ (ADDI ,regnum:third-arg ,regnum:free 0)
+ (JMPL ,regnum:first-arg ,regnum:assembler-temp 0)
+ (ADDI ,regnum:first-arg ,regnum:first-arg 8)
+ (LABEL ,label-arg)
+ (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
+ (+ 1
+ (* nentries closure-entry-size)
+ nvars)))
+ ,@(let expand ((offset 12) (entries entries))
+ (if (null? entries)
+ (LAP)
+ (let ((entry (car entries)))
+ (LAP
+ (LONG U ,(build-gc-offset-word
+ offset
+ (make-procedure-code-word (cadr entry)
+ (caddr entry))))
+ (LONG U (- ,(rtl-procedure/external-label (label->object (car entry)))
+ ,label-arg))
+ ,@(expand (+ offset (* 4 closure-entry-size))
+ (cdr entries))))))
+ (ADDI ,dest ,regnum:free 12)
+ (ADDI ,regnum:free ,regnum:free ,(* (+ (* nentries closure-entry-size) 2 nvars) 4))
+ )))
+\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 SPARC, 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* ((i1
+ (load-pc-relative-address regnum:second-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 (LD ,regnum:first-arg ,reg:environment)
+ ,@i1
+ (ST ,regnum:first-arg (OFFSET 0 ,regnum:second-arg))
+ ,@i2
+ ,@i3
+ ,@(load-immediate regnum:fourth-arg n-sections #F)
+ ,@(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 ()
+ (let ((i1 (load-pc-relative regnum:second-arg 'CODE code-block-label false)))
+ (LAP ,@i1
+ (LD ,regnum:fourth-arg ,reg:environment)
+ ,@(object->address regnum:second-arg regnum:second-arg)
+ ,@(add-immediate environment-offset regnum:second-arg regnum:first-arg)
+ (ST ,regnum:fourth-arg (OFFSET 0 ,regnum:first-arg))
+ ,@(add-immediate free-ref-offset regnum:second-arg regnum:third-arg)
+ ,@(load-immediate regnum:fourth-arg n-sections #F)
+ ,@(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)
+ (define (inner name assoc)
+ (if (null? assoc)
+ (transmogrifly (cdr uuos))
+ ; produces ((name . label) (0 . label) ... (frame-size . label) ...)
+ ; where the (0 . label) is repeated to fill out the size required
+ ; as specified in machin.scm
+ `((,name . ,(cdar assoc)) ; uuo-label
+ ,@(let loop ((count (max 0 (- execute-cache-size 2))))
+ (if (= count 0)
+ '()
+ (cons `(0 . ,(allocate-constant-label))
+ (loop (- count 1)))))
+ (,(caar assoc) . ; frame-size
+ ,(allocate-constant-label))
+ ,@(inner name (cdr assoc)))))
+ (if (null? uuos)
+ '()
+ ;; caar is name, cdar is alist of frame sizes
+ (inner (caar uuos) (cdar uuos))))
+#|
+(define (cons-closure target label min max nvars)
+ ;; Invoke an out-of-line handler to set up the closure's entry point.
+ ;; Arguments:
+ ;; - GR31: "Return address"
+ ;; GR31 points to a manifest closure header word, followed by a
+ ;; two-word closure descriptor, followed by the actual
+ ;; instructions to return to.
+ ;; The first word of the descriptor is the format+gc-offset word of
+ ;; the generated closure.
+ ;; The second word is the PC-relative JAL instruction.
+ ;; It is transformed into an absolute instruction by adding the shifted
+ ;; "return address".
+ ;; - GR4: Value to compare to closure free.
+ ;; - GR5: Increment for closure free.
+ ;; Returns closure in regnum:first-arg (GR4)
+ (rtl-target:=machine-register! target regnum:first-arg)
+ (require-register! regnum:first-arg)
+ (require-register! regnum:second-arg)
+ (require-register! regnum:third-arg)
+ (require-register! regnum:fourth-arg)
+ (let ((label-arg (generate-label)))
+ (LAP (ADDI ,regnum:second-arg ,regnum:scheme-to-interface -72)
+ (ADDI ,regnum:first-arg ,regnum:closure-free
+ ,(closure-test-size 1 nvars))
+ (JALR 31 ,regnum:second-arg)
+ (ADDI ,regnum:second-arg 0 ,(closure-bump-size 1 nvars))
+ (LABEL ,label-arg)
+ (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
+ (+ closure-entry-size nvars)))
+ (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max)))
+ (LONG U
+ (+ #x0c000000 ; JAL opcode
+ (/ (- ,(rtl-procedure/external-label (label->object label))
+ ,label-arg)
+ 4))))))
+|#
+
+
+\f
+;;; Local Variables: ***
+;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
+;;; End: ***
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rules4.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1988-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Interpreter Calls
+
+(declare (usual-integrations))
+\f
+;;;; Interpreter Calls
+
+(define-rule statement
+ (INTERPRETER-CALL:ACCESS (? environment register-expression) (? name))
+ (lookup-call code:compiler-access environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:LOOKUP (? environment register-expression)
+ (? name)
+ (? safe?))
+ (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
+ environment
+ name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNASSIGNED? (? environment register-expression) (? name))
+ (lookup-call code:compiler-unassigned? environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNBOUND? (? environment register-expression) (? name))
+ (lookup-call code:compiler-unbound? environment name))
+
+(define (lookup-call code environment name)
+ (LAP ,@(load-interface-args! false environment false false)
+ ,@(load-constant regnum:third-arg name #F #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-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rulfix.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Fixnum Rules
+;;; package: (compiler lap-syntaxer)
+
+(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 4))
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ #F))
+ (standard-unary-conversion source target object->index-fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ (OBJECT->FIXNUM (CONSTANT 4))
+ #F))
+ (standard-unary-conversion source target object->index-fixnum))
+
+;; This is a patch for the time being. Probably only one of these pairs
+;; of rules is needed.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (CONSTANT 4))
+ (REGISTER (? source))
+ #F))
+ (standard-unary-conversion source target fixnum->index-fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT 4))
+ #F))
+ (standard-unary-conversion source target fixnum->index-fixnum))
+\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-integrable (fixnum->index-fixnum src tgt)
+ ; Shift left 2 bits
+ (LAP (SLL ,tgt ,src 2)))
+
+(define-integrable (object->fixnum src tgt)
+ ; Shift left by scheme-type-width
+ (LAP (SLL ,tgt ,src ,scheme-type-width)))
+
+(define-integrable (object->index-fixnum src tgt)
+ ; Shift left by scheme-type-width+2
+ (LAP (SLL ,tgt ,src ,(+ scheme-type-width 2))))
+
+(define-integrable (address->fixnum src tgt)
+ ; Strip off type bits, just like object->fixnum
+ (LAP (SLL ,tgt ,src ,scheme-type-width)))
+
+(define-integrable (fixnum->object src tgt)
+ ; Move right by type code width and put on fixnum type code
+ (LAP (SRL ,tgt ,src ,scheme-type-width)
+ ,@(deposit-type-datum (ucode-type fixnum) tgt tgt)))
+
+(define (fixnum->address src tgt)
+ ; Move right by type code width and put in address bits
+ (LAP (SRL ,tgt ,src ,scheme-type-width)
+ (OR ,tgt ,tgt ,regnum:quad-bits)))
+
+(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
+ (LAP))
+ (lambda (if-no-overflow)
+ (LAP (BA (@PCR ,if-no-overflow))
+ (NOP)))))
+
+(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 '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))
+ ((= constant 0)
+ (no-overflow-branches!)
+ (LAP (ADDIU ,tgt ,src 0)))
+ (else
+ (let ((bcc (if (> constant 0) 'BLE 'BGE)))
+ (let ((prefix
+ (if (fits-in-16-bits-signed? constant)
+ (lambda (label)
+ (LAP (SUBCCI ,regnum:assembler-temp 0 ,src)
+ (,bcc ,regnum:assembler-temp (@PCR ,label))
+ (ADDIU ,tgt ,src ,constant)))
+ (with-values (lambda () (immediate->register constant))
+ (lambda (prefix alias)
+ (lambda (label)
+ (LAP ,@prefix
+ (,bcc ,src (@PCR ,label))
+ (ADDU ,tgt ,src ,alias))))))))
+ (if (> constant 0)
+ (set-current-branches!
+ (lambda (if-overflow)
+ (let ((if-no-overflow (generate-label)))
+ (LAP ,@(prefix if-no-overflow)
+ (SUBCCI ,regnum:assembler-temp 0 ,tgt)
+ (BLT ,tgt (@PCR ,if-overflow))
+ (NOP)
+ (LABEL ,if-no-overflow))))
+ (lambda (if-no-overflow)
+ (LAP ,@(prefix if-no-overflow)
+ (SUBCCI ,regnum:assembler-temp 0 ,tgt)
+ (BGE ,tgt (@PCR ,if-no-overflow))
+ (NOP))))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (let ((if-no-overflow (generate-label)))
+ (LAP ,@(prefix if-no-overflow)
+ (SUBCCI ,regnum:assembler-temp 0 ,tgt)
+ (BGE ,tgt (@PCR ,if-overflow))
+ (NOP)
+ (LABEL ,if-no-overflow))))
+ (lambda (if-no-overflow)
+ (LAP ,@(prefix if-no-overflow)
+ (BLTZ ,tgt (@PCR ,if-no-overflow))
+ (NOP)))))))
+ (LAP)))))
+\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 'PLUS-FIXNUM fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (do-overflow-addition tgt src1 src2)
+ (LAP (ADDU ,tgt ,src1 ,src2)))))
+
+;;; Use of REGNUM:ASSEMBLER-TEMP is OK here, but only because its
+;;; value is not used after the branch instruction that tests it.
+;;; The long form of the @PCR branch will test it correctly, but
+;;; clobbers it after testing.
+
+(define (do-overflow-addition tgt src1 src2)
+ (cond ((not (= src1 src2))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (let ((if-no-overflow (generate-label)))
+ (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
+ (BLTZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
+ (ADDU ,tgt ,src1 ,src2)
+ (XOR ,regnum:assembler-temp
+ ,tgt
+ ,(if (= tgt src1) src2 src1))
+ (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow))
+ (NOP)
+ (LABEL ,if-no-overflow))))
+ (lambda (if-no-overflow)
+ (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BLT ,regnum:assembler-temp (@PCR ,if-no-overflow))
+ (ADDU ,tgt ,src1 ,src2)
+ (XOR ,regnum:assembler-temp
+ ,tgt
+ ,(if (= tgt src1) src2 src1))
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
+ (NOP)))))
+ ((not (= tgt src1))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (ADDU ,tgt ,src1 ,src1)
+ (XOR ,regnum:assembler-temp ,tgt ,src1)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BLT ,regnum:assembler-temp (@PCR ,if-overflow))
+ (NOP)))
+ (lambda (if-no-overflow)
+ (LAP (ADDU ,tgt ,src1 ,src1)
+ (XOR ,regnum:assembler-temp ,tgt ,src1)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
+ (NOP)))))
+ (else
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (ADDU ,temp ,src1 ,src1)
+ (XOR ,regnum:assembler-temp ,temp ,src1)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BLT ,regnum:assembler-temp (@PCR ,if-overflow))
+ (ADD ,tgt 0 ,temp)))
+ (lambda (if-no-overflow)
+ (LAP (ADDU ,temp ,src1 ,src1)
+ (XOR ,regnum:assembler-temp ,temp ,src1)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
+ (ADD ,tgt 0 ,temp)))))))
+ (LAP))
+\f
+(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 (SUBU ,tgt ,src1 ,src1)))
+ (do-overflow-subtraction tgt src1 src2))
+ (LAP (SUB ,tgt ,src1 ,src2)))))
+
+(define (do-overflow-subtraction tgt src1 src2)
+ (set-current-branches!
+ (lambda (if-overflow)
+ (let ((if-no-overflow (generate-label)))
+ (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
+ (SUBU ,tgt ,src1 ,src2)
+ ,@(if (not (= tgt src1))
+ (LAP (XOR ,regnum:assembler-temp ,tgt ,src1)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BLT ,regnum:assembler-temp (@PCR ,if-overflow)))
+ (LAP (XOR ,regnum:assembler-temp ,tgt ,src2)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BGE ,regnum:assembler-temp (@PCR ,if-overflow))))
+ (NOP)
+ (LABEL ,if-no-overflow))))
+ (lambda (if-no-overflow)
+ (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
+ (SUBU ,tgt ,src1 ,src2)
+ ,@(if (not (= tgt src1))
+ (LAP (XOR ,regnum:assembler-temp ,tgt ,src1)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
+ (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow)))
+ (LAP (XOR ,regnum:assembler-temp ,tgt ,src2)
+ (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0g)
+ (BLT ,regnum:assembler-temp (@PCR ,if-no-overflow))))
+ (NOP))))
+ (LAP))
+
+(define (do-multiply tgt src1 src2 overflow?)
+ (if overflow?
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (MFHI ,temp)
+ (SRA ,regnum:assembler-temp ,tgt 31)
+ (BNE ,temp ,regnum:assembler-temp
+ (@PCR ,if-overflow))
+ (NOP)))
+ (lambda (if-no-overflow)
+ (LAP (MFHI ,temp)
+ (SRA ,regnum:assembler-temp ,tgt 31)
+ (BEQ ,temp ,regnum:assembler-temp
+ (@PCR ,if-no-overflow))
+ (NOP))))))
+ (LAP (SRA ,regnum:assembler-temp ,src1 ,scheme-type-width)
+ (MULT ,regnum:assembler-temp ,src2)
+ (MFLO ,tgt)))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args do-multiply)
+\f
+(define-rule statement
+ ;; execute binary fixnum operation with constant second arg
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (? overflow?)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ ((fixnum-2-args/operator/register*constant operation)
+ target source constant overflow?))))
+
+(define-rule statement
+ ;; execute binary fixnum operation with constant first arg
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (REGISTER (? source))
+ (? overflow?)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (if (fixnum-2-args/commutative? operation)
+ ((fixnum-2-args/operator/register*constant operation)
+ target source constant overflow?)
+ ((fixnum-2-args/operator/constant*register operation)
+ target constant source overflow?)))))
+
+(define (fixnum-2-args/commutative? operator)
+ (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
+
+(define (fixnum-2-args/operator/register*constant operation)
+ (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
+
+(define fixnum-methods/2-args/register*constant
+ (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
+
+(define (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 'MINUS-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 'MULTIPLY-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (tgt src constant overflow?)
+ (cond ((zero? constant)
+ (if overflow? (no-overflow-branches!))
+ (LAP (ADDI ,tgt 0 0)))
+ ((= constant 1)
+ (if overflow? (no-overflow-branches!))
+ (LAP (ADD ,tgt 0 ,src)))
+ ((let loop ((n constant))
+ (and (> n 0)
+ (if (= n 1)
+ 0
+ (and (even? n)
+ (let ((m (loop (quotient n 2))))
+ (and m
+ (+ m 1)))))))
+ =>
+ (lambda (power-of-two)
+ (if overflow?
+ (do-left-shift-overflow tgt src power-of-two)
+ (LAP (SLL ,tgt ,src ,power-of-two)))))
+ (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)
+ (if (= tgt src)
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (SLL ,temp ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,temp ,power-of-two)
+ (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
+ (ADD ,tgt 0 ,temp)))
+ (lambda (if-no-overflow)
+ (LAP (SLL ,temp ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,temp ,power-of-two)
+ (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
+ (ADD ,tgt 0 ,temp)))))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (SLL ,tgt ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
+ (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
+ (NOP)))
+ (lambda (if-no-overflow)
+ (LAP (SLL ,tgt ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
+ (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
+ (NOP)))))
+ (LAP))
+
+(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 (SUB ,tgt ,alias ,src))))))))
+\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-immediate (fixnum-pred-1->cc predicate)
+ 0
+ (standard-source! source)))
+
+(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))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rulflo.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+
+Copyright (c) 1989-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generation Rules: Flonum rules
+
+(declare (usual-integrations))
+\f
+(define (flonum-source! register)
+ (float-register->fpr (load-alias-register! register 'FLOAT)))
+
+(define (flonum-target! pseudo-register)
+ (delete-dead-registers!)
+ (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT)))
+
+(define (flonum-temporary!)
+ (float-register->fpr (allocate-temporary-register! 'FLOAT)))
+
+(define-rule statement
+ ;; convert a floating-point number to a flonum object
+ (ASSIGN (REGISTER (? target))
+ (FLOAT->OBJECT (REGISTER (? source))))
+ (let ((source (fpr->float-register (flonum-source! source))))
+ (let ((target (standard-target! target)))
+ (LAP
+ ; (SW 0 (OFFSET 0 ,regnum:free)) ; make heap parsable forwards
+ (ORI ,regnum:free ,regnum:free #b100) ; Align to odd quad byte
+ ,@(deposit-type-address (ucode-type flonum) regnum:free target)
+ ,@(with-values
+ (lambda ()
+ (immediate->register
+ (make-non-pointer-literal (ucode-type manifest-nm-vector) 2)))
+ (lambda (prefix alias)
+ (LAP ,@prefix
+ (SW ,alias (OFFSET 0 ,regnum:free)))))
+ ,@(fp-store-doubleword 4 regnum:free source)
+ (ADDI ,regnum:free ,regnum:free 12)))))
+
+(define-rule statement
+ ;; convert a flonum object to a floating-point number
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
+ (let ((source (standard-move-to-temporary! source)))
+ (let ((target (fpr->float-register (flonum-target! target))))
+ (LAP ,@(object->address source source)
+ ,@(fp-load-doubleword 4 source target #T)))))
+\f
+;;;; Flonum Arithmetic
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
+ overflow? ;ignore
+ (let ((source (flonum-source! source)))
+ ((flonum-1-arg/operator operation) (flonum-target! target) source)))
+
+(define (flonum-1-arg/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/1-arg))
+
+(define flonum-methods/1-arg
+ (list 'FLONUM-METHODS/1-ARG))
+
+;;; Notice the weird ,', syntax here.
+;;; If LAP changes, this may also have to change.
+
+(let-syntax
+ ((define-flonum-operation
+ (macro (primitive-name opcode)
+ `(define-arithmetic-method ',primitive-name flonum-methods/1-arg
+ (lambda (target source)
+ (LAP (,opcode ,',target ,',source)))))))
+ (define-flonum-operation flonum-abs ABS.D)
+ (define-flonum-operation flonum-negate NEG.D))
+
+(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 ,',target ,',source1 ,',source2)))))))
+ (define-flonum-operation flonum-add ADD.D)
+ (define-flonum-operation flonum-subtract SUB.D)
+ (define-flonum-operation flonum-multiply MUL.D)
+ (define-flonum-operation flonum-divide DIV.D))
+\f
+;;;; Flonum Predicates
+
+(define-rule predicate
+ (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ ;; No immediate zeros, easy to generate by subtracting from itself
+ (let ((temp (flonum-temporary!))
+ (source (flonum-source! source)))
+ (LAP (MTC1 0 ,temp)
+ (MTC1 0 ,(+ temp 1))
+ (NOP)
+ ,@(flonum-compare
+ (case predicate
+ ((FLONUM-ZERO?) 'C.EQ.D)
+ ((FLONUM-NEGATIVE?) 'C.LT.D)
+ ((FLONUM-POSITIVE?) 'C.GT.D)
+ (else (error "unknown flonum predicate" predicate)))
+ source temp))))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (flonum-compare (case predicate
+ ((FLONUM-EQUAL?) 'C.EQ.D)
+ ((FLONUM-LESS?) 'C.LT.D)
+ ((FLONUM-GREATER?) 'C.GT.D)
+ (else (error "unknown flonum predicate" predicate)))
+ (flonum-source! source1)
+ (flonum-source! source2)))
+
+(define (flonum-compare cc r1 r2)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (BC1T (@PCR ,label)) (NOP)))
+ (lambda (label)
+ (LAP (BC1F (@PCR ,label)) (NOP))))
+ (if (eq? cc 'C.GT.D)
+ (LAP (C.LT.D ,r2 ,r1) (NOP))
+ (LAP (,cc ,r1 ,r2) (NOP))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rulrew.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $
+$MC68020-Header: rulrew.scm,v 1.1 90/01/18 22:48:52 GMT cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rewrite Rules
+
+(declare (usual-integrations))
+\f
+;;;; Synthesized Data
+#|
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (REGISTER (? datum register-known-value)))
+ (QUALIFIER (and (rtl:machine-constant? type)
+ (rtl:machine-constant? datum)))
+ (rtl:make-cons-pointer type datum))
+
+;; I've copied these rules from the MC68020. -- Jinx.
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
+ (QUALIFIER
+ (and (rtl:object->type? type)
+ (rtl:constant? (rtl:object->type-expression type))))
+ (rtl:make-cons-pointer
+ (rtl:make-machine-constant
+ (object-type (rtl:object->type-expression datum)))
+ datum))
+
+(define-rule rewriting
+ (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
+ (QUALIFIER
+ (and (rtl:object->datum? datum)
+ (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
+ (rtl:make-cons-pointer
+ type
+ (rtl:make-machine-constant
+ (careful-object-datum (rtl:object->datum-expression datum)))))
+
+(define-rule rewriting
+ (OBJECT->TYPE (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant? source))
+ (rtl:make-machine-constant (object-type (rtl:constant-value source))))
+
+(define-rule rewriting
+ (OBJECT->DATUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-non-pointer? source))
+ (rtl:make-machine-constant (careful-object-datum source)))
+
+(define (rtl:constant-non-pointer? expression)
+ (and (rtl:constant? expression)
+ (non-pointer-object? (rtl:constant-value expression))))
+\f
+;; I've modified these rules from the MC68020. -- Jinx
+
+;;; These rules are losers because there's no abstract way to cons a
+;;; statement or a predicate without also getting some CFG structure.
+
+(define-rule rewriting
+ ;; Use register 0, always 0.
+ (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'ASSIGN target (rtl:make-machine-constant 0)))
+
+(define-rule rewriting
+ ;; Compare to register 0, always 0.
+ (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-constant 0)))
+
+(define-rule rewriting
+ ;; Compare to register 0, always 0.
+ (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-constant 0)))
+
+(define (rtl:immediate-zero-constant? expression)
+ (cond ((rtl:constant? expression)
+ (let ((value (rtl:constant-value expression)))
+ (and (non-pointer-object? value)
+ (zero? (object-type value))
+ (zero? (careful-object-datum value)))))
+ ((rtl:cons-pointer? expression)
+ (and (let ((expression (rtl:cons-pointer-type expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))
+ (let ((expression (rtl:cons-pointer-datum expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))))
+ (else false)))
+\f
+;;;; Fixnums
+
+;; I've copied this rule from the MC68020. -- Jinx
+;; It should probably be qualified to be in the immediate range.
+
+(define-rule rewriting
+ (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-fixnum? source))
+ (rtl:make-object->fixnum source))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (REGISTER (? operand-1 register-known-value))
+ (? operand-2)
+ #F)
+ (QUALIFIER (rtl:constant-fixnum-4? operand-1))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ #F)
+ (QUALIFIER (rtl:constant-fixnum-4? operand-2))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (REGISTER (? operand-1 register-known-value))
+ (? operand-2)
+ #F)
+ (QUALIFIER
+ (and (rtl:object->fixnum-of-register? operand-1)
+ (rtl:constant-fixnum-4? operand-2)))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
+
+(define-rule rewriting
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-value))
+ #F)
+ (QUALIFIER
+ (and (rtl:constant-fixnum-4? operand-1)
+ (rtl:object->fixnum-of-register? operand-2)))
+ (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
+
+(define (rtl:constant-fixnum? expression)
+ (and (rtl:constant? expression)
+ (fix:fixnum? (rtl:constant-value expression))))
+
+(define (rtl:constant-fixnum-4? expression)
+ (and (rtl:object->fixnum? expression)
+ (let ((expression (rtl:object->fixnum-expression expression)))
+ (and (rtl:constant? expression)
+ (eqv? 4 (rtl:constant-value expression))))))
+
+(define (rtl:object->fixnum-of-register? expression)
+ (and (rtl:object->fixnum? expression)
+ (rtl:register? (rtl:object->fixnum-expression expression))))
+\f
+;;;; Closures and othe optimizations.
+
+;; These rules are Spectrum specific
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (REGISTER (? datum register-known-value)))
+ (QUALIFIER (and (rtl:machine-constant? type)
+ (= (rtl:machine-constant-value type)
+ (ucode-type compiled-entry))
+ (or (rtl:entry:continuation? datum)
+ (rtl:entry:procedure? datum)
+ (rtl:cons-closure? datum))))
+ (rtl:make-cons-pointer type datum))
+|#
+
+#|
+;; Not yet written.
+
+;; A type is compatible when a depi instruction can put it in assuming that
+;; the datum has the quad bits set.
+;; A register is a machine-address-register if it is a machine register and
+;; always contains an address (ie. free pointer, stack pointer, or dlink register)
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (REGISTER (? datum machine-address-register)))
+ (QUALIFIER (and (rtl:machine-constant? type)
+ (spectrum-type-optimizable? (rtl:machine-constant-value type))))
+ (rtl:make-cons-pointer type datum))
+|#
+
+
+
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+$Id: c.c,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "liarc.h"
+#include "bignum.h"
+#include "bitstr.h"
+
+extern void EXFUN (lose_big_1, (char *, char *));
+\f
+#ifdef BUG_GCC_LONG_CALLS
+
+extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
+extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
+extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
+extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
+extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *));
+extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *));
+extern SCHEME_OBJECT EXFUN (search_for_primitive,
+ (SCHEME_OBJECT, char *, Boolean, Boolean, int));
+
+SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ()) =
+{
+ ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_string),
+ ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_symbol),
+ ((SCHEME_OBJECT EXFUN ((*), ())) make_vector),
+ ((SCHEME_OBJECT EXFUN ((*), ())) cons),
+ ((SCHEME_OBJECT EXFUN ((*), ())) rconsm),
+ ((SCHEME_OBJECT EXFUN ((*), ())) double_to_flonum),
+ ((SCHEME_OBJECT EXFUN ((*), ())) long_to_integer),
+ ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_integer),
+ ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_bit_string),
+ ((SCHEME_OBJECT EXFUN ((*), ())) search_for_primitive)
+};
+
+#endif /* BUG_GCC_LONG_CALLS */
+\f
+extern char * interface_to_C_hook;
+extern void EXFUN (C_to_interface, (PTR));
+extern void EXFUN (interface_initialize, (void));
+extern SCHEME_OBJECT * EXFUN (initialize_C_compiled_block, (int, char *));
+extern void EXFUN (initialize_compiled_code_blocks, (void));
+
+typedef SCHEME_OBJECT * EXFUN ((* compiled_block), (SCHEME_OBJECT *));
+
+int pc_zero_bits;
+char * interface_to_C_hook;
+static compiled_block * compiled_code_blocks;
+static char ** compiled_block_names;
+static int max_compiled_code_blocks, compiled_code_blocks_size;
+static SCHEME_OBJECT dummy_entry = SHARP_F;
+
+SCHEME_OBJECT *
+DEFUN (trampoline_procedure, (trampoline), SCHEME_OBJECT * trampoline)
+{
+ return (invoke_utility ((LABEL_TAG (trampoline)),
+ ((long) (TRAMPOLINE_STORAGE (trampoline))),
+ 0, 0, 0));
+}
+\f
+void
+DEFUN_VOID (NO_SUBBLOCKS)
+{
+ return;
+}
+
+int
+DEFUN (declare_compiled_code, (name, decl_proc, code_proc),
+ char * name
+ AND void EXFUN (decl_proc, (void))
+ AND SCHEME_OBJECT * EXFUN (code_proc, (SCHEME_OBJECT *)))
+{
+ int index;
+
+ index = max_compiled_code_blocks;
+ max_compiled_code_blocks += 1;
+ if ((MAKE_LABEL_WORD (index, 0)) == dummy_entry)
+ return (0);
+
+ if (index >= compiled_code_blocks_size)
+ {
+ compiled_block * new_blocks;
+ char ** new_names;
+ compiled_code_blocks_size = ((compiled_code_blocks_size == 0)
+ ? 10
+ : (compiled_code_blocks_size * 2));
+ new_blocks =
+ ((compiled_block *)
+ (realloc (compiled_code_blocks,
+ (compiled_code_blocks_size * (sizeof (compiled_block))))));
+
+ new_names =
+ ((char **)
+ (realloc (compiled_block_names,
+ (compiled_code_blocks_size * (sizeof (char *))))));
+
+ if ((new_blocks == ((compiled_block *) NULL))
+ || (new_names == ((char **) NULL)))
+ return (0);
+ compiled_code_blocks = new_blocks;
+ compiled_block_names = new_names;
+ }
+ compiled_code_blocks[index] = (code_proc);
+ compiled_block_names[index] = name;
+ decl_proc ();
+ return (index);
+}
+
+void
+DEFUN_VOID (interface_initialize)
+{
+ int i, pow, del;
+
+ for (i = 0, pow = 1, del = ((sizeof (SCHEME_OBJECT)) / (sizeof (char)));
+ pow < del;
+ i+= 1)
+ pow = (pow << 1);
+
+ if (pow != del)
+ lose_big ("initialize_compiler: not a power of two");
+
+ pc_zero_bits = i;
+
+ dummy_entry = (MAKE_LABEL_WORD (-1, 0));
+ interface_to_C_hook = ((char *) &dummy_entry);
+ max_compiled_code_blocks = 0;
+ compiled_code_blocks_size = 0;
+ compiled_code_blocks = ((compiled_block *) NULL);
+ compiled_block_names = ((char **) NULL);
+ (void) declare_compiled_code ("", NO_SUBBLOCKS, trampoline_procedure);
+
+ initialize_compiled_code_blocks ();
+
+ return;
+}
+\f
+/* For now this is a linear search.
+ Not that it matters much, but we could easily
+ make it binary.
+ */
+
+int
+DEFUN (find_compiled_block, (name), char * name)
+{
+ int i;
+
+ for (i = 1; i < max_compiled_code_blocks; i++)
+ {
+ if ((strcmp (name, compiled_block_names[i])) == 0)
+ return (i);
+ }
+ return (0);
+}
+
+SCHEME_OBJECT
+DEFUN (initialize_subblock, (name), char * name)
+{
+ SCHEME_OBJECT id, * ep, * block;
+ int slot = (find_compiled_block (name));
+
+ if (slot == 0)
+ error_external_return ();
+
+ id = (MAKE_LABEL_WORD (slot, 0));
+ ep = ((* (compiled_code_blocks[slot])) (&id));
+ Get_Compiled_Block (block, ep);
+ return (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block));
+}
+
+SCHEME_OBJECT *
+DEFUN (initialize_C_compiled_block, (argno, name),
+ int argno AND char * name)
+{
+ int slot;
+ SCHEME_OBJECT id;
+ slot = (find_compiled_block (name));
+ if (slot == 0)
+ return ((SCHEME_OBJECT *) NULL);
+
+ id = (MAKE_LABEL_WORD (slot, 0));
+ return ((* (compiled_code_blocks[slot])) (&id));
+}
+\f
+void
+DEFUN (C_to_interface, (entry), PTR in_entry)
+{
+ SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) in_entry);
+ while (1)
+ {
+ int proc_index;
+ proc_index = (LABEL_PROCEDURE (entry));
+ if (proc_index >= max_compiled_code_blocks)
+ {
+ if (entry != &dummy_entry)
+#if 0
+ {
+ /* We need to export C_return_value before enabling this code. */
+ Store_Expression ((SCHEME_OBJECT) entry);
+ C_return_value = (ERR_EXECUTE_MANIFEST_VECTOR);
+ return;
+ }
+#else
+ lose_big ("C_to_interface: non-existent procedure");
+#endif
+ return;
+ }
+ else
+ entry = ((* (compiled_code_blocks [proc_index])) (entry));
+ }
+}
+
+typedef SCHEME_OBJECT * EXFUN
+ ((* utility_table_entry), (long, long, long, long));
+
+extern utility_table_entry utility_table[];
+
+SCHEME_OBJECT *
+DEFUN (invoke_utility, (code, arg1, arg2, arg3, arg4),
+ int code AND long arg1 AND long arg2 AND long arg3 AND long arg4)
+{
+ return ((* utility_table[code]) (arg1, arg2, arg3, arg4));
+}
+\f
+int
+DEFUN (multiply_with_overflow, (x, y, res), long x AND long y AND long * res)
+{
+ extern SCHEME_OBJECT EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT));
+ SCHEME_OBJECT ans;
+
+ ans = (Mul ((LONG_TO_FIXNUM (x)), (LONG_TO_FIXNUM (y))));
+ if (ans == SHARP_F)
+ {
+ /* Bogus... */
+ * res = (x * y);
+ return (1);
+ }
+ else
+ {
+ * res = (FIXNUM_TO_LONG (ans));
+ return (0);
+ }
+}
+
+void
+DEFUN (lose_big, (msg), char * msg)
+{
+ fprintf (stderr, "\nlose_big: %s.\n", msg);
+ Microcode_Termination (TERM_EXIT);
+ /*NOTREACHED*/
+}
+
+void
+DEFUN (lose_big_1, (msg, arg), char * msg AND char * arg)
+{
+ fprintf (stderr, "\nlose_big: %s (%s).\n", msg, arg);
+ Microcode_Termination (TERM_EXIT);
+ /*NOTREACHED*/
+}
+
+void
+DEFUN_VOID (error_band_already_built)
+{
+ lose_big ("Trying to initilize data with the wrong binary.");
+ /*NOTREACHED*/
+}
+\f
+/* This avoids consing the string and symbol if it already exists. */
+
+SCHEME_OBJECT
+DEFUN (memory_to_symbol, (length, string),
+ long length AND unsigned char * string)
+{
+ extern SCHEME_OBJECT EXFUN (find_symbol, (long, unsigned char *));
+ extern SCHEME_OBJECT EXFUN (string_to_symbol, (SCHEME_OBJECT));
+ SCHEME_OBJECT symbol;
+
+ symbol = (find_symbol (length, string));
+ if (symbol != SHARP_F)
+ return (symbol);
+ return (string_to_symbol (memory_to_string (length, string)));
+}
+
+static unsigned int
+DEFUN (hex_digit_to_int, (h_digit), char h_digit)
+{
+ unsigned int digit = ((unsigned int) h_digit);
+
+ return (((digit >= '0') && (digit <= '9'))
+ ? (digit - '0')
+ : (((digit >= 'A') && (digit <= 'F'))
+ ? ((digit - 'A') + 10)
+ : ((digit - 'a') + 10)));
+}
+
+static unsigned int
+DEFUN (digit_string_producer, (digit_ptr), char ** digit_ptr)
+{
+ char digit = ** digit_ptr;
+ * digit_ptr = ((* digit_ptr) + 1);
+ return (hex_digit_to_int (digit));
+}
+
+SCHEME_OBJECT
+DEFUN (digit_string_to_integer, (negative_p, n_digits, digits),
+ Boolean negative_p AND long n_digits AND char * digits)
+{
+ char * digit = digits;
+
+ return (digit_stream_to_bignum (((int) n_digits),
+ digit_string_producer,
+ ((PTR) & digit),
+ 16,
+ ((int) negative_p)));
+}
+
+SCHEME_OBJECT
+DEFUN (digit_string_to_bit_string, (n_bits, n_digits, digits),
+ long n_bits AND long n_digits AND char * digits)
+{
+ extern void EXFUN (clear_bit_string, (SCHEME_OBJECT));
+ extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long));
+ extern void EXFUN (bit_string_set, (SCHEME_OBJECT, long, int));
+ SCHEME_OBJECT result = (allocate_bit_string (n_bits));
+ unsigned int digit, mask;
+ long i, posn;
+ int j;
+
+ posn = 0;
+ clear_bit_string (result);
+
+ for (i = 0; i < n_digits; i++)
+ {
+ digit = (hex_digit_to_int (*digits++));
+ for (j = 0, mask = 1;
+ j < 4;
+ j++, mask = (mask << 1), posn++)
+ if ((digit & mask) != 0)
+ bit_string_set (result, posn, 1);
+ }
+ return (result);
+}
+\f
+#ifdef USE_STDARG
+
+SCHEME_OBJECT
+DEFUN (rconsm, (nargs, tail DOTS),
+ int nargs AND SCHEME_OBJECT tail DOTS)
+{
+ va_list arg_ptr;
+ va_start (arg_ptr, tail);
+ {
+ int i;
+ SCHEME_OBJECT result = tail;
+ for (i = 1; i < nargs; i++)
+ result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)),
+ result));
+
+ va_end (arg_ptr);
+ return (result);
+ }
+}
+
+#else /* not USE_STDARG */
+
+SCHEME_OBJECT
+rconsm (va_alist)
+va_dcl
+{
+ va_list arg_ptr;
+ int nargs;
+ SCHEME_OBJECT tail;
+
+ va_start (arg_ptr);
+ nargs = (va_arg (arg_ptr, int));
+ tail = (va_arg (arg_ptr, SCHEME_OBJECT));
+
+ {
+ int i;
+ SCHEME_OBJECT result = tail;
+ for (i = 1; i < nargs; i++)
+ result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)),
+ result));
+
+ va_end (arg_ptr);
+ return (result);
+ }
+}
+
+#endif /* USE_STDARG */
--- /dev/null
+/* -*-C-*-
+
+$Id: c.h,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef CMPINT2_H_INCLUDED
+#define CMPINT2_H_INCLUDED
+
+#include "limits.h"
+\f
+#define COMPILER_NONE_TYPE 0
+#define COMPILER_MC68020_TYPE 1
+#define COMPILER_VAX_TYPE 2
+#define COMPILER_SPECTRUM_TYPE 3
+#define COMPILER_OLD_MIPS_TYPE 4
+#define COMPILER_MC68040_TYPE 5
+#define COMPILER_SPARC_TYPE 6
+#define COMPILER_RS6000_TYPE 7
+#define COMPILER_MC88K_TYPE 8
+#define COMPILER_I386_TYPE 9
+#define COMPILER_ALPHA_TYPE 10
+#define COMPILER_MIPS_TYPE 11
+#define COMPILER_LOSING_C_TYPE 12
+
+#define COMPILER_PROCESSOR_TYPE COMPILER_LOSING_C_TYPE
+
+#define HALF_OBJECT_LENGTH (OBJECT_LENGTH / 2)
+#define HALF_OBJECT_LOW_MASK ((((unsigned long) 1) << HALF_OBJECT_LENGTH) - 1)
+#define HALF_OBJECT_HIGH_MASK (HALF_OBJECT_LOW_MASK << HALF_OBJECT_LENGTH)
+
+#define MAKE_LABEL_WORD(proc_tag,dispatch) \
+((SCHEME_OBJECT) \
+ (((((unsigned long) proc_tag) & HALF_OBJECT_LOW_MASK) \
+ << HALF_OBJECT_LENGTH) \
+ | (((unsigned long) dispatch) & HALF_OBJECT_LOW_MASK)))
+
+#define LABEL_PROCEDURE(pc) \
+(((* ((unsigned long *) (pc))) >> HALF_OBJECT_LENGTH) \
+ & HALF_OBJECT_LOW_MASK)
+
+#define LABEL_TAG(pc) \
+((* ((unsigned long *) (pc))) & HALF_OBJECT_LOW_MASK)
+
+#define WRITE_LABEL_DESCRIPTOR(entry,kind,offset) do \
+{ \
+ SCHEME_OBJECT * ent = ((SCHEME_OBJECT *) (entry)); \
+ \
+ COMPILED_ENTRY_FORMAT_WORD (entry) = (kind); \
+ COMPILED_ENTRY_OFFSET_WORD (entry) = \
+ (WORD_OFFSET_TO_OFFSET_WORD (offset)); \
+} while (0)
+
+#define CC_BLOCK_DISTANCE(block,entry) \
+ (((SCHEME_OBJECT *) (entry)) - ((SCHEME_OBJECT *) (block)))
+
+typedef unsigned short format_word;
+
+extern int pc_zero_bits;
+
+#define PC_ZERO_BITS pc_zero_bits
+
+/* arbitrary */
+#define ENTRY_PREFIX_LENGTH 2
+
+#define ADJUST_CLOSURE_AT_CALL(entry_point, location) do { } while (0)
+
+#define COMPILED_CLOSURE_ENTRY_SIZE ((sizeof (SCHEME_OBJECT)) * 3)
+
+#define EXTRACT_CLOSURE_ENTRY_ADDRESS(output,location) do \
+{ \
+ (output) = (((SCHEME_OBJECT *) (location))[1]); \
+} while (0)
+
+#define STORE_CLOSURE_ENTRY_ADDRESS(input,location) do \
+{ \
+ ((SCHEME_OBJECT *) (location))[1] = ((SCHEME_OBJECT) (input)); \
+} while (0)
+\f
+/* Trampolines are implemented as tiny compiled code blocks that
+ invoke the constant C procedure indexed by the number 0.
+ */
+
+#define TRAMPOLINE_ENTRY_SIZE 2 /* Words */
+
+#define TRAMPOLINE_BLOCK_TO_ENTRY 3
+
+#define TRAMPOLINE_ENTRY_POINT(tramp_block) \
+ (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
+
+#define TRAMPOLINE_STORAGE(tramp_entry) \
+ ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
+ (2 + TRAMPOLINE_ENTRY_SIZE))
+
+#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \
+{ \
+ ((SCHEME_OBJECT *) (entry_address))[0] \
+ = (MAKE_LABEL_WORD (0, (index))); \
+} while (0)
+
+/* An execute cache contains a compiled entry for the callee,
+ and a number of arguments (+ 1).
+ */
+
+#define EXECUTE_CACHE_ENTRY_SIZE 2
+
+#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) do \
+{ \
+ (target) = ((long) (((SCHEME_OBJECT *) (address))[1])); \
+} while (0)
+
+#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) do \
+{ \
+ (target) = (((SCHEME_OBJECT *) (address))[0]); \
+} while (0)
+
+#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) do \
+{ \
+ (target) = (((SCHEME_OBJECT *) (address)) [0]); \
+} while (0)
+
+#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) do \
+{ \
+ ((SCHEME_OBJECT *) (address))[0] = ((SCHEME_OBJECT) (entry)); \
+} while (0)
+
+#define STORE_EXECUTE_CACHE_CODE(address) do { } while (0)
+
+extern void EXFUN (interface_initialize, (void));
+
+#define ASM_RESET_HOOK() interface_initialize ()
+\f
+/* Derived parameters and macros.
+
+ These macros expect the above definitions to be meaningful.
+ If they are not, the macros below may have to be changed as well.
+ */
+
+#define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1])
+#define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2])
+
+/* The next one assumes 2's complement integers....*/
+#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
+#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
+
+#define WORD_OFFSET_TO_OFFSET_WORD(words) ((words) << 1)
+
+#define BYTE_OFFSET_TO_OFFSET_WORD(bytes) \
+ WORD_OFFSET_TO_OFFSET_WORD ((bytes) / (sizeof (SCHEME_OBJECT)))
+
+#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
+ ((sizeof (SCHEME_OBJECT)) * ((CLEAR_LOW_BIT (offset_word)) >> 1))
+
+#define MAKE_OFFSET_WORD(entry, block, continue) \
+ ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
+ ((char *) (block)))) | \
+ ((continue) ? 1 : 0))
+
+#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
+ ((count) >> 1)
+#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
+ ((entries) << 1)
+\f
+/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
+ a format word and a gc offset word. See the early part of the
+ TRAMPOLINE picture, above.
+ */
+
+#define CC_BLOCK_FIRST_ENTRY_OFFSET \
+ (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
+
+/* Format words */
+
+#define FORMAT_BYTE_EXPR 0xFF
+#define FORMAT_BYTE_COMPLR 0xFE
+#define FORMAT_BYTE_CMPINT 0xFD
+#define FORMAT_BYTE_DLINK 0xFC
+#define FORMAT_BYTE_RETURN 0xFB
+
+#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
+#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
+#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
+
+/* This assumes that a format word is at least 16 bits,
+ and the low order field is always 8 bits.
+ */
+
+#define MAKE_FORMAT_WORD(field1, field2) \
+ (((field1) << 8) | ((field2) & 0xff))
+
+#define SIGN_EXTEND_FIELD(field, size) \
+ (((field) & ((1 << (size)) - 1)) | \
+ ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
+ ((-1) << (size))))
+
+#define FORMAT_WORD_LOW_BYTE(word) \
+ (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8))
+
+#define FORMAT_WORD_HIGH_BYTE(word) \
+ (SIGN_EXTEND_FIELD \
+ ((((unsigned long) (word)) >> 8), \
+ (((sizeof (format_word)) * CHAR_BIT) - 8)))
+
+#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
+ (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
+
+#define COMPILED_ENTRY_FORMAT_LOW(addr) \
+ (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
+
+#define FORMAT_BYTE_FRAMEMAX 0x7f
+
+#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
+#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
+
+#endif /* CMPINT2_H_INCLUDED */
--- /dev/null
+/* -*- C -*- */
+
+#include "liarc.h"
+
+#undef DECLARE_COMPILED_CODE
+
+#define DECLARE_COMPILED_CODE(name, decl, code) do \
+{ \
+ extern void EXFUN (decl, (void)); \
+ extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *)); \
+ if ((declare_compiled_code (name, decl, code)) == 0) \
+ lose_big_1 ("DECLARE_COMPILED_CODE: duplicate tag", name); \
+} while (0)
+
+extern void EXFUN (lose_big_1, (char *, char *));
+
+void
+DEFUN_VOID (initialize_compiled_code_blocks)
+{
+#include "compinit.h"
+ return;
+}
--- /dev/null
+/* -*-C-*-
+
+$Id: liarc.h,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef LIARC_INCLUDED
+#define LIARC_INCLUDED
+
+#include <stdio.h>
+#include "ansidecl.h"
+#include "config.h"
+#include "default.h"
+#include "object.h"
+#include "sdata.h"
+#include "types.h"
+#include "errors.h"
+#include "const.h"
+#include "interp.h"
+#include "prim.h"
+#include "cmpgc.h"
+#include "cmpint2.h"
+
+#ifdef __STDC__
+# define USE_STDARG
+# include <stdarg.h>
+#else
+# include <varargs.h>
+#endif /* __STDC__ */
+
+/* #define USE_GLOBAL_VARIABLES */
+#define USE_SHORTCKT_JUMP
+
+typedef unsigned long ulong;
+
+extern PTR dstack_position;
+extern SCHEME_OBJECT * Free;
+extern SCHEME_OBJECT * Ext_Stack_Pointer;
+extern SCHEME_OBJECT Registers[];
+
+extern void EXFUN (lose_big, (char *));
+extern int EXFUN (multiply_with_overflow, (long, long, long *));
+extern SCHEME_OBJECT * EXFUN (invoke_utility, (int, long, long, long, long));
+extern void EXFUN (error_band_already_built, (void));
+\f
+#define ERROR_UNKNOWN_DISPATCH( pc ) lose_big ("Unknown tag.")
+
+#define ADDRESS_UNITS_PER_OBJECT (sizeof (SCHEME_OBJECT))
+
+#undef FIXNUM_TO_LONG
+#define FIXNUM_TO_LONG(source) \
+ ((((long) (source)) << TYPE_CODE_LENGTH) >> TYPE_CODE_LENGTH)
+
+#define ADDRESS_TO_LONG(source) ((long) (source))
+
+#define LONG_TO_ADDRESS(source) (DATUM_TO_ADDRESS (source))
+
+#define C_STRING_TO_SCHEME_STRING(len,str) \
+ (MEMORY_TO_STRING ((len), (unsigned char *) str))
+
+#define C_SYM_INTERN(len,str) \
+ (MEMORY_TO_SYMBOL ((len), ((unsigned char *) str)))
+
+#define MAKE_PRIMITIVE_PROCEDURE(name,arity) \
+ (SEARCH_FOR_PRIMITIVE (SHARP_F, name, true, true, arity))
+
+#define MAKE_LINKER_HEADER(kind,count) \
+ (OBJECT_NEW_TYPE (TC_FIXNUM, \
+ (MAKE_LINKAGE_SECTION_HEADER ((kind), (count)))))
+
+#define ALLOCATE_VECTOR(len) (MAKE_VECTOR ((len), SHARP_F, true))
+
+#define ALLOCATE_RECORD(len) \
+ (OBJECT_NEW_TYPE (TC_RECORD, (ALLOCATE_VECTOR (len))))
+
+#define RECORD_SET(rec,off,val) VECTOR_SET(rec,off,val)
+
+#define INLINE_DOUBLE_TO_FLONUM(src,tgt) do \
+{ \
+ double num = (src); \
+ SCHEME_OBJECT * val; \
+ \
+ ALIGN_FLOAT (free_pointer); \
+ val = free_pointer; \
+ free_pointer += (1 + (BYTES_TO_WORDS (sizeof (double)))); \
+ * val = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \
+ (BYTES_TO_WORDS (sizeof (double))))); \
+ (* ((double *) (val + 1))) = num; \
+ (tgt) = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (val))); \
+} while (0)
+
+#define MAKE_RATIO(num,den) \
+ (OBJECT_NEW_TYPE (TC_RATNUM, (CONS (num, den))))
+
+#define MAKE_COMPLEX(real,imag) \
+ (OBJECT_NEW_TYPE (TC_COMPLEX, (CONS (real, imag))))
+
+#define CC_BLOCK_TO_ENTRY(block,offset) \
+ (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, \
+ ((OBJECT_ADDRESS (block)) + (offset))))
+\f
+#ifdef USE_GLOBAL_VARIABLES
+
+#define value_reg Val
+#define free_pointer Free
+#define register_block Regs
+#define stack_pointer Stack_Pointer
+
+#define DECLARE_VARIABLES() int unsed_variable_to_keep_C_happy
+#define UNCACHE_VARIABLES() do {} while (0)
+#define CACHE_VARIABLES() do {} while (0)
+
+#else /* not USE_GLOBAL_VARIABLES */
+
+#define REGISTER register
+
+#define register_block Regs
+
+#define DECLARE_VARIABLES() \
+REGISTER SCHEME_OBJECT value_reg = Val; \
+REGISTER SCHEME_OBJECT * free_pointer = Free; \
+REGISTER SCHEME_OBJECT * stack_pointer = Stack_Pointer
+
+#define UNCACHE_VARIABLES() do \
+{ \
+ Stack_Pointer = stack_pointer; \
+ Free = free_pointer; \
+ Val = value_reg; \
+} while (0)
+
+#define CACHE_VARIABLES() do \
+{ \
+ value_reg = Val; \
+ free_pointer = Free; \
+ stack_pointer = Stack_Pointer; \
+} while (0)
+
+#endif /* USE_GLOBAL_VARIABLES */
+
+#define REPEAT_DISPATCH() do \
+{ \
+ if ((LABEL_PROCEDURE (my_pc)) != current_C_proc) \
+ { \
+ UNCACHE_VARIABLES (); \
+ return (my_pc); \
+ } \
+ /* fall through. */ \
+} while (0)
+
+#ifdef USE_SHORTCKT_JUMP
+
+#define JUMP(destination) do \
+{ \
+ my_pc = (destination); \
+ goto repeat_dispatch; \
+} while(0)
+
+#define JUMP_EXTERNAL(destination) do \
+{ \
+ my_pc = (destination); \
+ if ((LABEL_PROCEDURE (my_pc)) == current_C_proc) \
+ { \
+ CACHE_VARIABLES (); \
+ goto perform_dispatch; \
+ } \
+ return (my_pc); \
+} while (0)
+
+#define JUMP_EXECUTE_CHACHE(entry) do \
+{ \
+ my_pc = ((SCHEME_OBJECT *) current_block[entry]); \
+ goto repeat_dispatch; \
+} while (0)
+
+#define POP_RETURN() goto pop_return_repeat_dispatch
+
+#define POP_RETURN_REPEAT_DISPATCH() do \
+{ \
+ my_pc = (OBJECT_ADDRESS (*stack_pointer++)); \
+ /* fall through to repeat_dispatch */ \
+} while (0)
+
+#else /* not USE_SHORTCKT_JUMP */
+
+#define JUMP(destination) do \
+{ \
+ UNCACHE_VARIABLES (); \
+ return (destination); \
+} while (0)
+
+#define JUMP_EXTERNAL(destination) return (destination)
+
+#define JUMP_EXECUTE_CHACHE(entry) do \
+{ \
+ SCHEME_OBJECT* destination \
+ = ((SCHEME_OBJECT *) current_block[entry]); \
+ \
+ JUMP (destination); \
+} while (0)
+
+#define POP_RETURN() do \
+{ \
+ SCHEME_OBJECT target = *stack_pointer++; \
+ SCHEME_OBJECT destination = (OBJECT_ADDRESS (target)); \
+ JUMP (destination); \
+} while (0)
+
+#define POP_RETURN_REPEAT_DISPATCH() do \
+{ \
+} while (0)
+
+#endif /* USE_SHORTCKT_JUMP */
+\f
+#define INVOKE_PRIMITIVE(prim, nargs) do \
+{ \
+ primitive = (prim); \
+ primitive_nargs = (nargs); \
+ goto invoke_primitive; \
+} while (0)
+
+#define INVOKE_PRIMITIVE_CODE() do \
+{ \
+ SCHEME_OBJECT * destination; \
+ \
+ UNCACHE_VARIABLES (); \
+ PRIMITIVE_APPLY (Val, primitive); \
+ POP_PRIMITIVE_FRAME (primitive_nargs); \
+ destination = (OBJECT_ADDRESS (STACK_POP ())); \
+ JUMP_EXTERNAL (destination); \
+} while(0)
+
+#define INVOKE_INTERFACE_CODE() do \
+{ \
+ SCHEME_OBJECT * destination; \
+ \
+ UNCACHE_VARIABLES (); \
+ destination = (invoke_utility (subtmp_code, subtmp_1, subtmp_2, \
+ subtmp_3, subtmp_4)); \
+ JUMP_EXTERNAL (destination); \
+} while (0)
+
+#define INVOKE_INTERFACE_4(code, one, two, three, four) do \
+{ \
+ subtmp_4 = ((long) (four)); \
+ subtmp_3 = ((long) (three)); \
+ subtmp_2 = ((long) (two)); \
+ subtmp_1 = ((long) (one)); \
+ subtmp_code = (code); \
+ goto invoke_interface_4; \
+} while (0)
+
+#define INVOKE_INTERFACE_3(code, one, two, three) do \
+{ \
+ subtmp_3 = ((long) (three)); \
+ subtmp_2 = ((long) (two)); \
+ subtmp_1 = ((long) (one)); \
+ subtmp_code = (code); \
+ goto invoke_interface_3; \
+} while (0)
+
+#define INVOKE_INTERFACE_2(code, one, two) do \
+{ \
+ subtmp_2 = ((long) (two)); \
+ subtmp_1 = ((long) (one)); \
+ subtmp_code = (code); \
+ goto invoke_interface_2; \
+} while (0)
+
+#define INVOKE_INTERFACE_1(code, one) do \
+{ \
+ subtmp_1 = ((long) (one)); \
+ subtmp_code = (code); \
+ goto invoke_interface_1; \
+} while (0)
+
+#define INVOKE_INTERFACE_0(code) do \
+{ \
+ subtmp_code = (code); \
+ goto invoke_interface_0; \
+} while (0)
+\f
+#define MAX_BIT_SHIFT DATUM_LENGTH
+
+#define RIGHT_SHIFT_UNSIGNED(source, number) \
+(((number) > MAX_BIT_SHIFT) \
+ ? 0 \
+ : ((((unsigned long) (source)) & DATUM_MASK) \
+ >> (number)))
+
+#define RIGHT_SHIFT(source, number) \
+(((number) > MAX_BIT_SHIFT) \
+ ? 0 \
+ : ((source) >> (number)))
+
+#define LEFT_SHIFT(source, number) \
+(((number) > MAX_BIT_SHIFT) \
+ ? 0 \
+ : ((source) << (number)))
+
+#define FIXNUM_LSH(source, number) \
+(((number) >= 0) \
+ ? (LEFT_SHIFT (source, number)) \
+ : (RIGHT_SHIFT_UNSIGNED (source, (- (number)))))
+
+#define FIXNUM_REMAINDER(source1, source2) \
+(((source2) > 0) \
+ ? (((source1) >= 0) \
+ ? ((source1) % (source2)) \
+ : (- ((- (source1)) % (source2)))) \
+ : (((source1) >= 0) \
+ ? ((source1) % (- (source2))) \
+ : (- ((- (source1)) % (- (source2))))))
+
+#define FIXNUM_QUOTIENT(source1, source2) \
+(((source2) > 0) \
+ ? (((source1) >= 0) \
+ ? ((source1) / (source2)) \
+ : (- ((- (source1)) / (source2)))) \
+ : (((source1) >= 0) \
+ ? (- ((source1) / (- (source2)))) \
+ : ((- (source1)) / (- (source2)))))
+\f
+#define CLOSURE_HEADER(offset) do \
+{ \
+ SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) my_pc[1]); \
+ current_block = (entry - offset); \
+ *--stack_pointer = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, my_pc)); \
+} while (0)
+
+#define CLOSURE_INTERRUPT_CHECK(code) do \
+{ \
+ if (((long) free_pointer) \
+ >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_0 (code); \
+} while (0)
+
+#define INTERRUPT_CHECK(code, entry_point) do \
+{ \
+ if (((long) free_pointer) \
+ >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]); \
+} while (0)
+
+#define DLINK_INTERRUPT_CHECK(code, entry_point) do \
+{ \
+ if (((long) free_pointer) \
+ >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], \
+ dynamic_link); \
+} while (0)
+
+/* This does nothing in the sources. */
+
+#define DECLARE_COMPILED_CODE(string, decl, code) \
+extern void EXFUN (decl, (void)); \
+extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *));
+
+#ifdef USE_STDARG
+# define RCONSM_TYPE(frob) SCHEME_OBJECT EXFUN (frob, (int, SCHEME_OBJECT DOTS))
+#else /* not USE_STDARG */
+# define RCONSM_TYPE(frob) SCHEME_OBJECT frob ()
+#endif /* USE_STDARG */
+
+extern RCONSM_TYPE(rconsm);
+\f
+struct compiled_file
+{
+ int number_of_procedures;
+ char ** names;
+ void * EXFUN ((**procs), (void));
+};
+
+extern int EXFUN (declare_compiled_code,
+ (char *,
+ void EXFUN ((*), (void)),
+ SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *))));
+extern SCHEME_OBJECT EXFUN (initialize_subblock, (char *));
+extern void EXFUN (NO_SUBBLOCKS, (void));
+\f
+#ifdef __GNUC__
+# ifdef hp9000s800
+# define BUG_GCC_LONG_CALLS
+# endif
+#endif
+
+#ifndef BUG_GCC_LONG_CALLS
+
+extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
+extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
+extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
+extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
+extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *));
+extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *));
+extern SCHEME_OBJECT EXFUN (search_for_primitive,
+ (SCHEME_OBJECT, char *, Boolean, Boolean, int));
+
+#define MEMORY_TO_STRING memory_to_string
+#define MEMORY_TO_SYMBOL memory_to_symbol
+#define MAKE_VECTOR make_vector
+#define CONS cons
+#define RCONSM rconsm
+#define DOUBLE_TO_FLONUM double_to_flonum
+#define LONG_TO_INTEGER long_to_integer
+#define DIGIT_STRING_TO_INTEGER digit_string_to_integer
+#define DIGIT_STRING_TO_BIT_STRING digit_string_to_bit_string
+#define SEARCH_FOR_PRIMITIVE search_for_primitive
+
+#else /* GCC on Specturm has a strange bug so do thing differently .... */
+
+extern SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ());
+
+#define MEMORY_TO_STRING \
+ ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) (constructor_kludge[0]))
+
+#define MEMORY_TO_SYMBOL \
+ ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) (constructor_kludge[1]))
+
+#define MAKE_VECTOR \
+ ((SCHEME_OBJECT EXFUN ((*), (long, SCHEME_OBJECT, Boolean))) (constructor_kludge[2]))
+
+#define CONS \
+ ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, SCHEME_OBJECT))) (constructor_kludge[3]))
+
+#define RCONSM \
+ ((RCONSM_TYPE ((*))) (constructor_kludge[4]))
+
+#define DOUBLE_TO_FLONUM \
+ ((SCHEME_OBJECT EXFUN ((*), (double))) (constructor_kludge[5]))
+
+#define LONG_TO_INTEGER \
+ ((SCHEME_OBJECT EXFUN ((*), (long))) (constructor_kludge[6]))
+
+#define DIGIT_STRING_TO_INTEGER \
+ ((SCHEME_OBJECT EXFUN ((*), (Boolean, long, char *))) (constructor_kludge[7]))
+
+#define DIGIT_STRING_TO_BIT_STRING \
+ ((SCHEME_OBJECT EXFUN ((*), (long, long, char *))) (constructor_kludge[8]))
+
+#define SEARCH_FOR_PRIMITIVE \
+ ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, char *, \
+ Boolean, Boolean, int))) \
+ (constructor_kludge[9]))
+
+#endif /* BUG_GCC_LONG_CALLS */
+
+#endif /* LIARC_INCLUDED */
--- /dev/null
+/* -*-C-*-
+
+$Id: liarc.h,v 1.1 1993/06/08 06:13:32 gjr Exp $
+
+Copyright (c) 1992-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef LIARC_INCLUDED
+#define LIARC_INCLUDED
+
+#include <stdio.h>
+#include "ansidecl.h"
+#include "config.h"
+#include "default.h"
+#include "object.h"
+#include "sdata.h"
+#include "types.h"
+#include "errors.h"
+#include "const.h"
+#include "interp.h"
+#include "prim.h"
+#include "cmpgc.h"
+#include "cmpint2.h"
+
+#ifdef __STDC__
+# define USE_STDARG
+# include <stdarg.h>
+#else
+# include <varargs.h>
+#endif /* __STDC__ */
+
+/* #define USE_GLOBAL_VARIABLES */
+#define USE_SHORTCKT_JUMP
+
+typedef unsigned long ulong;
+
+extern PTR dstack_position;
+extern SCHEME_OBJECT * Free;
+extern SCHEME_OBJECT * Ext_Stack_Pointer;
+extern SCHEME_OBJECT Registers[];
+
+extern void EXFUN (lose_big, (char *));
+extern int EXFUN (multiply_with_overflow, (long, long, long *));
+extern SCHEME_OBJECT * EXFUN (invoke_utility, (int, long, long, long, long));
+extern void EXFUN (error_band_already_built, (void));
+\f
+#define ERROR_UNKNOWN_DISPATCH( pc ) lose_big ("Unknown tag.")
+
+#define ADDRESS_UNITS_PER_OBJECT (sizeof (SCHEME_OBJECT))
+
+#undef FIXNUM_TO_LONG
+#define FIXNUM_TO_LONG(source) \
+ ((((long) (source)) << TYPE_CODE_LENGTH) >> TYPE_CODE_LENGTH)
+
+#define ADDRESS_TO_LONG(source) ((long) (source))
+
+#define LONG_TO_ADDRESS(source) (DATUM_TO_ADDRESS (source))
+
+#define C_STRING_TO_SCHEME_STRING(len,str) \
+ (MEMORY_TO_STRING ((len), (unsigned char *) str))
+
+#define C_SYM_INTERN(len,str) \
+ (MEMORY_TO_SYMBOL ((len), ((unsigned char *) str)))
+
+#define MAKE_PRIMITIVE_PROCEDURE(name,arity) \
+ (SEARCH_FOR_PRIMITIVE (SHARP_F, name, true, true, arity))
+
+#define MAKE_LINKER_HEADER(kind,count) \
+ (OBJECT_NEW_TYPE (TC_FIXNUM, \
+ (MAKE_LINKAGE_SECTION_HEADER ((kind), (count)))))
+
+#define ALLOCATE_VECTOR(len) (MAKE_VECTOR ((len), SHARP_F, true))
+
+#define ALLOCATE_RECORD(len) \
+ (OBJECT_NEW_TYPE (TC_RECORD, (ALLOCATE_VECTOR (len))))
+
+#define RECORD_SET(rec,off,val) VECTOR_SET(rec,off,val)
+
+#define INLINE_DOUBLE_TO_FLONUM(src,tgt) do \
+{ \
+ double num = (src); \
+ SCHEME_OBJECT * val; \
+ \
+ ALIGN_FLOAT (free_pointer); \
+ val = free_pointer; \
+ free_pointer += (1 + (BYTES_TO_WORDS (sizeof (double)))); \
+ * val = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \
+ (BYTES_TO_WORDS (sizeof (double))))); \
+ (* ((double *) (val + 1))) = num; \
+ (tgt) = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (val))); \
+} while (0)
+
+#define MAKE_RATIO(num,den) \
+ (OBJECT_NEW_TYPE (TC_RATNUM, (CONS (num, den))))
+
+#define MAKE_COMPLEX(real,imag) \
+ (OBJECT_NEW_TYPE (TC_COMPLEX, (CONS (real, imag))))
+
+#define CC_BLOCK_TO_ENTRY(block,offset) \
+ (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, \
+ ((OBJECT_ADDRESS (block)) + (offset))))
+\f
+#ifdef USE_GLOBAL_VARIABLES
+
+#define value_reg Val
+#define free_pointer Free
+#define register_block Regs
+#define stack_pointer Stack_Pointer
+
+#define DECLARE_VARIABLES() int unsed_variable_to_keep_C_happy
+#define UNCACHE_VARIABLES() do {} while (0)
+#define CACHE_VARIABLES() do {} while (0)
+
+#else /* not USE_GLOBAL_VARIABLES */
+
+#define REGISTER register
+
+#define register_block Regs
+
+#define DECLARE_VARIABLES() \
+REGISTER SCHEME_OBJECT value_reg = Val; \
+REGISTER SCHEME_OBJECT * free_pointer = Free; \
+REGISTER SCHEME_OBJECT * stack_pointer = Stack_Pointer
+
+#define UNCACHE_VARIABLES() do \
+{ \
+ Stack_Pointer = stack_pointer; \
+ Free = free_pointer; \
+ Val = value_reg; \
+} while (0)
+
+#define CACHE_VARIABLES() do \
+{ \
+ value_reg = Val; \
+ free_pointer = Free; \
+ stack_pointer = Stack_Pointer; \
+} while (0)
+
+#endif /* USE_GLOBAL_VARIABLES */
+
+#define REPEAT_DISPATCH() do \
+{ \
+ if ((LABEL_PROCEDURE (my_pc)) != current_C_proc) \
+ { \
+ UNCACHE_VARIABLES (); \
+ return (my_pc); \
+ } \
+ /* fall through. */ \
+} while (0)
+
+#ifdef USE_SHORTCKT_JUMP
+
+#define JUMP(destination) do \
+{ \
+ my_pc = (destination); \
+ goto repeat_dispatch; \
+} while(0)
+
+#define JUMP_EXTERNAL(destination) do \
+{ \
+ my_pc = (destination); \
+ if ((LABEL_PROCEDURE (my_pc)) == current_C_proc) \
+ { \
+ CACHE_VARIABLES (); \
+ goto perform_dispatch; \
+ } \
+ return (my_pc); \
+} while (0)
+
+#define JUMP_EXECUTE_CHACHE(entry) do \
+{ \
+ my_pc = ((SCHEME_OBJECT *) current_block[entry]); \
+ goto repeat_dispatch; \
+} while (0)
+
+#define POP_RETURN() goto pop_return_repeat_dispatch
+
+#define POP_RETURN_REPEAT_DISPATCH() do \
+{ \
+ my_pc = (OBJECT_ADDRESS (*stack_pointer++)); \
+ /* fall through to repeat_dispatch */ \
+} while (0)
+
+#else /* not USE_SHORTCKT_JUMP */
+
+#define JUMP(destination) do \
+{ \
+ UNCACHE_VARIABLES (); \
+ return (destination); \
+} while (0)
+
+#define JUMP_EXTERNAL(destination) return (destination)
+
+#define JUMP_EXECUTE_CHACHE(entry) do \
+{ \
+ SCHEME_OBJECT* destination \
+ = ((SCHEME_OBJECT *) current_block[entry]); \
+ \
+ JUMP (destination); \
+} while (0)
+
+#define POP_RETURN() do \
+{ \
+ SCHEME_OBJECT target = *stack_pointer++; \
+ SCHEME_OBJECT destination = (OBJECT_ADDRESS (target)); \
+ JUMP (destination); \
+} while (0)
+
+#define POP_RETURN_REPEAT_DISPATCH() do \
+{ \
+} while (0)
+
+#endif /* USE_SHORTCKT_JUMP */
+\f
+#define INVOKE_PRIMITIVE(prim, nargs) do \
+{ \
+ primitive = (prim); \
+ primitive_nargs = (nargs); \
+ goto invoke_primitive; \
+} while (0)
+
+#define INVOKE_PRIMITIVE_CODE() do \
+{ \
+ SCHEME_OBJECT * destination; \
+ \
+ UNCACHE_VARIABLES (); \
+ PRIMITIVE_APPLY (Val, primitive); \
+ POP_PRIMITIVE_FRAME (primitive_nargs); \
+ destination = (OBJECT_ADDRESS (STACK_POP ())); \
+ JUMP_EXTERNAL (destination); \
+} while(0)
+
+#define INVOKE_INTERFACE_CODE() do \
+{ \
+ SCHEME_OBJECT * destination; \
+ \
+ UNCACHE_VARIABLES (); \
+ destination = (invoke_utility (subtmp_code, subtmp_1, subtmp_2, \
+ subtmp_3, subtmp_4)); \
+ JUMP_EXTERNAL (destination); \
+} while (0)
+
+#define INVOKE_INTERFACE_4(code, one, two, three, four) do \
+{ \
+ subtmp_4 = ((long) (four)); \
+ subtmp_3 = ((long) (three)); \
+ subtmp_2 = ((long) (two)); \
+ subtmp_1 = ((long) (one)); \
+ subtmp_code = (code); \
+ goto invoke_interface_4; \
+} while (0)
+
+#define INVOKE_INTERFACE_3(code, one, two, three) do \
+{ \
+ subtmp_3 = ((long) (three)); \
+ subtmp_2 = ((long) (two)); \
+ subtmp_1 = ((long) (one)); \
+ subtmp_code = (code); \
+ goto invoke_interface_3; \
+} while (0)
+
+#define INVOKE_INTERFACE_2(code, one, two) do \
+{ \
+ subtmp_2 = ((long) (two)); \
+ subtmp_1 = ((long) (one)); \
+ subtmp_code = (code); \
+ goto invoke_interface_2; \
+} while (0)
+
+#define INVOKE_INTERFACE_1(code, one) do \
+{ \
+ subtmp_1 = ((long) (one)); \
+ subtmp_code = (code); \
+ goto invoke_interface_1; \
+} while (0)
+
+#define INVOKE_INTERFACE_0(code) do \
+{ \
+ subtmp_code = (code); \
+ goto invoke_interface_0; \
+} while (0)
+\f
+#define MAX_BIT_SHIFT DATUM_LENGTH
+
+#define RIGHT_SHIFT_UNSIGNED(source, number) \
+(((number) > MAX_BIT_SHIFT) \
+ ? 0 \
+ : ((((unsigned long) (source)) & DATUM_MASK) \
+ >> (number)))
+
+#define RIGHT_SHIFT(source, number) \
+(((number) > MAX_BIT_SHIFT) \
+ ? 0 \
+ : ((source) >> (number)))
+
+#define LEFT_SHIFT(source, number) \
+(((number) > MAX_BIT_SHIFT) \
+ ? 0 \
+ : ((source) << (number)))
+
+#define FIXNUM_LSH(source, number) \
+(((number) >= 0) \
+ ? (LEFT_SHIFT (source, number)) \
+ : (RIGHT_SHIFT_UNSIGNED (source, (- (number)))))
+
+#define FIXNUM_REMAINDER(source1, source2) \
+(((source2) > 0) \
+ ? (((source1) >= 0) \
+ ? ((source1) % (source2)) \
+ : (- ((- (source1)) % (source2)))) \
+ : (((source1) >= 0) \
+ ? ((source1) % (- (source2))) \
+ : (- ((- (source1)) % (- (source2))))))
+
+#define FIXNUM_QUOTIENT(source1, source2) \
+(((source2) > 0) \
+ ? (((source1) >= 0) \
+ ? ((source1) / (source2)) \
+ : (- ((- (source1)) / (source2)))) \
+ : (((source1) >= 0) \
+ ? (- ((source1) / (- (source2)))) \
+ : ((- (source1)) / (- (source2)))))
+\f
+#define CLOSURE_HEADER(offset) do \
+{ \
+ SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) my_pc[1]); \
+ current_block = (entry - offset); \
+ *--stack_pointer = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, my_pc)); \
+} while (0)
+
+#define CLOSURE_INTERRUPT_CHECK(code) do \
+{ \
+ if (((long) free_pointer) \
+ >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_0 (code); \
+} while (0)
+
+#define INTERRUPT_CHECK(code, entry_point) do \
+{ \
+ if (((long) free_pointer) \
+ >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]); \
+} while (0)
+
+#define DLINK_INTERRUPT_CHECK(code, entry_point) do \
+{ \
+ if (((long) free_pointer) \
+ >= ((long) (register_block[REGBLOCK_MEMTOP]))) \
+ INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], \
+ dynamic_link); \
+} while (0)
+
+/* This does nothing in the sources. */
+
+#define DECLARE_COMPILED_CODE(string, decl, code) \
+extern void EXFUN (decl, (void)); \
+extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *));
+
+#ifdef USE_STDARG
+# define RCONSM_TYPE(frob) SCHEME_OBJECT EXFUN (frob, (int, SCHEME_OBJECT DOTS))
+#else /* not USE_STDARG */
+# define RCONSM_TYPE(frob) SCHEME_OBJECT frob ()
+#endif /* USE_STDARG */
+
+extern RCONSM_TYPE(rconsm);
+\f
+struct compiled_file
+{
+ int number_of_procedures;
+ char ** names;
+ void * EXFUN ((**procs), (void));
+};
+
+extern int EXFUN (declare_compiled_code,
+ (char *,
+ void EXFUN ((*), (void)),
+ SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *))));
+extern SCHEME_OBJECT EXFUN (initialize_subblock, (char *));
+extern void EXFUN (NO_SUBBLOCKS, (void));
+\f
+#ifdef __GNUC__
+# ifdef hp9000s800
+# define BUG_GCC_LONG_CALLS
+# endif
+#endif
+
+#ifndef BUG_GCC_LONG_CALLS
+
+extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
+extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
+extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
+extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
+extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *));
+extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *));
+extern SCHEME_OBJECT EXFUN (search_for_primitive,
+ (SCHEME_OBJECT, char *, Boolean, Boolean, int));
+
+#define MEMORY_TO_STRING memory_to_string
+#define MEMORY_TO_SYMBOL memory_to_symbol
+#define MAKE_VECTOR make_vector
+#define CONS cons
+#define RCONSM rconsm
+#define DOUBLE_TO_FLONUM double_to_flonum
+#define LONG_TO_INTEGER long_to_integer
+#define DIGIT_STRING_TO_INTEGER digit_string_to_integer
+#define DIGIT_STRING_TO_BIT_STRING digit_string_to_bit_string
+#define SEARCH_FOR_PRIMITIVE search_for_primitive
+
+#else /* GCC on Specturm has a strange bug so do thing differently .... */
+
+extern SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ());
+
+#define MEMORY_TO_STRING \
+ ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) (constructor_kludge[0]))
+
+#define MEMORY_TO_SYMBOL \
+ ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) (constructor_kludge[1]))
+
+#define MAKE_VECTOR \
+ ((SCHEME_OBJECT EXFUN ((*), (long, SCHEME_OBJECT, Boolean))) (constructor_kludge[2]))
+
+#define CONS \
+ ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, SCHEME_OBJECT))) (constructor_kludge[3]))
+
+#define RCONSM \
+ ((RCONSM_TYPE ((*))) (constructor_kludge[4]))
+
+#define DOUBLE_TO_FLONUM \
+ ((SCHEME_OBJECT EXFUN ((*), (double))) (constructor_kludge[5]))
+
+#define LONG_TO_INTEGER \
+ ((SCHEME_OBJECT EXFUN ((*), (long))) (constructor_kludge[6]))
+
+#define DIGIT_STRING_TO_INTEGER \
+ ((SCHEME_OBJECT EXFUN ((*), (Boolean, long, char *))) (constructor_kludge[7]))
+
+#define DIGIT_STRING_TO_BIT_STRING \
+ ((SCHEME_OBJECT EXFUN ((*), (long, long, char *))) (constructor_kludge[8]))
+
+#define SEARCH_FOR_PRIMITIVE \
+ ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, char *, \
+ Boolean, Boolean, int))) \
+ (constructor_kludge[9]))
+
+#endif /* BUG_GCC_LONG_CALLS */
+
+#endif /* LIARC_INCLUDED */
projects / mit-scheme.git / commitdiff