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