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