From: Guillermo J. Rozas Date: Tue, 8 Jun 1993 06:13:32 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~8355 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d1bcf9331e88764b908efca52e3510a11fa2d18e;p=mit-scheme.git Initial revision --- diff --git a/v7/src/compiler/machines/C/compiler.cbf b/v7/src/compiler/machines/C/compiler.cbf new file mode 100644 index 000000000..a8323eae2 --- /dev/null +++ b/v7/src/compiler/machines/C/compiler.cbf @@ -0,0 +1,45 @@ +#| -*-Scheme-*- + +$Id: compiler.cbf,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Script to incrementally compile the compiler (from .bins) + +(for-each compile-directory + '("back" + "base" + "fggen" + "fgopt" + "machines/C" + "rtlbase" + "rtlgen" + "rtlopt")) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/compiler.pkg b/v7/src/compiler/machines/C/compiler.pkg new file mode 100644 index 000000000..c76f39ace --- /dev/null +++ b/v7/src/compiler/machines/C/compiler.pkg @@ -0,0 +1,648 @@ +#| -*-Scheme-*- + +$Id: compiler.pkg,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Packaging + +(global-definitions "../runtime/runtim") + +(define-package (compiler) + (files "base/switch" + "base/hashtb" + "base/object" ;tagged object support + "base/enumer" ;enumerations + "base/sets" ;set abstraction + "base/mvalue" ;multiple-value support + "base/scode" ;SCode abstraction + "rtlbase/valclass" ;RTL: value classes + "machines/C/machin" ;machine dependent stuff + "machines/C/cutl" ;back-end odds and ends + "base/utils" ;odds and ends + + "base/cfg1" ;control flow graph + "base/cfg2" + "base/cfg3" + + "base/ctypes" ;CFG datatypes + + "base/rvalue" ;Right hand values + "base/lvalue" ;Left hand values + "base/blocks" ;rvalue: blocks + "base/proced" ;rvalue: procedures + "base/contin" ;rvalue: continuations + + "base/subprb" ;subproblem datatype + + "rtlbase/rgraph" ;program graph abstraction + "rtlbase/rtlty1" ;RTL: type definitions + "rtlbase/rtlty2" ;RTL: type definitions + "rtlbase/rtlexp" ;RTL: expression operations + "rtlbase/rtlcon" ;RTL: complex constructors + "rtlbase/rtlreg" ;RTL: registers + "rtlbase/rtlcfg" ;RTL: CFG types + "rtlbase/rtlobj" ;RTL: CFG objects + "rtlbase/regset" ;RTL: register sets + + "back/insseq" ;LAP instruction sequences + ) + (parent ()) + (export () + compiler:analyze-side-effects? + compiler:cache-free-variables? + compiler:code-compression? + compiler:compile-by-procedures? + compiler:cse? + compiler:default-top-level-declarations + compiler:enable-expansion-declarations? + compiler:enable-integration-declarations? + compiler:generate-lap-files? + compiler:generate-range-checks? + compiler:generate-rtl-files? + compiler:generate-stack-checks? + compiler:generate-type-checks? + compiler:implicit-self-static? + compiler:intersperse-rtl-in-lap? + compiler:noisy? + compiler:open-code-flonum-checks? + compiler:open-code-primitives? + compiler:optimize-environments? + compiler:package-optimization-level + compiler:preserve-data-structures? + compiler:show-phases? + compiler:show-procedures? + compiler:show-subphases? + compiler:show-time-reports? + compiler:use-multiclosures?)) + +(define-package (compiler reference-contexts) + (files "base/refctx") + (parent (compiler)) + (export (compiler) + add-reference-context/adjacent-parents! + initialize-reference-contexts! + make-reference-context + modify-reference-contexts! + reference-context/adjacent-parent? + reference-context/block + reference-context/offset + reference-context/procedure + reference-context? + set-reference-context/offset!)) + +(define-package (compiler balanced-binary-tree) + (files "base/btree") + (parent (compiler)) + (export (compiler) + btree-delete! + btree-fringe + btree-insert! + btree-lookup + make-btree)) + +(define-package (compiler macros) + (files "base/macros") + (parent ()) + (export (compiler) + assembler-syntax-table + compiler-syntax-table + early-syntax-table + lap-generator-syntax-table) + (import (runtime macros) + parse-define-syntax) + (initialization (initialize-package!))) + +(define-package (compiler declarations) + (files "machines/C/decls") + (parent (compiler)) + (export (compiler) + sc + syntax-files!) + (import (scode-optimizer top-level) + sf/internal) + (initialization (initialize-package!))) + +(define-package (compiler top-level) + (files "base/toplev" + ;; "base/crstop" + ;; "base/asstop" + "machines/C/ctop") + (parent (compiler)) + (export () + cbf + cf + compile-bin-file + compile-procedure + compile-scode + compiler:reset! + ;; cross-compile-bin-file + ;; cross-compile-bin-file-end + ) + (export (compiler) + canonicalize-label-name) + (export (compiler fg-generator) + compile-recursively) + (export (compiler rtl-generator) + *ic-procedure-headers* + *rtl-continuations* + *rtl-expression* + *rtl-graphs* + *rtl-procedures*) + (export (compiler lap-syntaxer) + *block-label* + *disambiguator* + *external-labels* + *special-labels* + label->object + *invoke-interface* + *used-invoke-primitive* + *use-jump-execute-chache* + *use-pop-return* + *purification-root-object*) + (export (compiler debug) + *root-expression* + *rtl-procedures* + *rtl-graphs*) + (import (runtime compiler-info) + make-dbg-info-vector + split-inf-structure!) + (import (runtime unparser) + *unparse-uninterned-symbols-by-name?*)) + +(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/C/rgspcm" ;special close-coded primitives + "rtlbase/rtline" ;linearizer + ) + (parent (compiler)) + (export (compiler) + make-linearizer) + (export (compiler top-level) + generate/top-level + linearize-rtl + setup-bblock-continuations!) + (export (compiler debug) + linearize-rtl) + (import (compiler top-level) + label->object)) + +(define-package (compiler rtl-generator generate/procedure-header) + (files "rtlgen/rgproc") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) generate/procedure-header)) + +(define-package (compiler rtl-generator combination/inline) + (files "rtlgen/opncod") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) combination/inline) + (export (compiler top-level) open-coding-analysis)) + +(define-package (compiler rtl-generator find-block) + (files "rtlgen/fndblk") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) find-block)) + +(define-package (compiler rtl-generator generate/rvalue) + (files "rtlgen/rgrval") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) + generate/rvalue + load-closure-environment + make-cons-closure-indirection + make-cons-closure-redirection + make-closure-redirection + make-ic-cons + make-non-trivial-closure-cons + make-trivial-closure-cons + redirect-closure)) + +(define-package (compiler rtl-generator generate/combination) + (files "rtlgen/rgcomb") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) + generate/combination) + (export (compiler rtl-generator combination/inline) + generate/invocation-prefix)) + +(define-package (compiler rtl-generator generate/return) + (files "rtlgen/rgretn") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) + make-return-operand + generate/return + generate/return* + generate/trivial-return)) + +(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/regmap" ;Hardware register allocator + "machines/C/cout" ;converts partial C code into one one big string + "machines/C/lapgen" ;code generation rules + "machines/C/rules1" ; " " " + "machines/C/rules2" ; " " " + "machines/C/rules3" ; " " " + "machines/C/rules4" ; " " " + "machines/C/rulfix" ; " " " + "machines/C/rulflo" ; " " " + "machines/C/rulrew" ;code rewriting rules + ) + (parent (compiler)) + (export () + *C-procedure-name*) + (export (compiler) + available-machine-registers + fits-in-16-bits-signed? + fits-in-16-bits-unsigned? + top-16-bits-only? + lap-generator/match-rtl-instruction + lap:make-entry-point + lap:make-label-statement + lap:make-unconditional-branch + lap:syntax-instruction) + (export (compiler top-level) + current-register-list + fake-compiled-block-name + free-assignments + free-references + free-uuo-links + generate-lap + global-uuo-links + label-num + labels + make-fake-compiled-block + make-fake-compiled-procedure + make-special-labels + make-table + objects + permanent-register-list + stringify) + (import (scode-optimizer expansion) + scode->scode-expander)) + +(define-package (compiler lap-syntaxer map-merger) + (files "back/mermap") + (parent (compiler lap-syntaxer)) + (export (compiler lap-syntaxer) + merge-register-maps)) + +(define-package (compiler lap-syntaxer linearizer) + (files "back/linear") + (parent (compiler lap-syntaxer)) + (export (compiler lap-syntaxer) + add-end-of-block-code! + bblock-linearize-lap + linearize-lap + set-current-branches!) + (export (compiler top-level) + *end-of-block-code* + linearize-lap)) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/compiler.sf b/v7/src/compiler/machines/C/compiler.sf new file mode 100644 index 000000000..ec64fd3fb --- /dev/null +++ b/v7/src/compiler/machines/C/compiler.sf @@ -0,0 +1,89 @@ +#| -*-Scheme-*- + +$Id: compiler.sf,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Script to incrementally syntax the compiler + +;; Guarantee that the package modeller is loaded. +(if (not (name->package '(CROSS-REFERENCE))) + (with-working-directory-pathname "../cref" (lambda () (load "make")))) + +;; Guarantee that the compiler's package structure exists. +(if (not (name->package '(COMPILER))) + (begin + ;; If there is no existing package constructor, generate one. + (if (not (file-exists? "comp.bcon")) + (begin + ((access cref/generate-trivial-constructor + (->environment '(CROSS-REFERENCE))) + "comp") + (sf "comp.con" "comp.bcon"))) + (load "comp.bcon"))) + +;; Guarantee that the necessary syntactic transforms and optimizers +;; are loaded. +(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!) + (let ((sf-and-load + (lambda (files package) + (sf-conditionally files) + (for-each (lambda (file) + (load (string-append file ".bin") package)) + files)))) + (write-string "\n\n---- Loading compile-time files ----") + (sf-and-load '("base/switch" "base/hashtb") '(COMPILER)) + (sf-and-load '("base/macros") '(COMPILER MACROS)) + ((access initialize-package! (->environment '(COMPILER MACROS)))) + (sf-and-load '("machines/C/decls") '(COMPILER DECLARATIONS)) + (let ((environment (->environment '(COMPILER DECLARATIONS)))) + (set! (access source-file-expression environment) "*.scm") + ((access initialize-package! environment))) + (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP)) + (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER)) + (sf-and-load '("rtlbase/valclass") '(COMPILER)) + (fluid-let ((sf/default-syntax-table + (access compiler-syntax-table + (->environment '(COMPILER MACROS))))) + (sf-and-load '("machines/C/machin") '(COMPILER))) + (set! (access endianness (->environment '(COMPILER))) 'BIG) + (sf-and-load '("back/syntax") + '(COMPILER LAP-SYNTAXER)) + (sf-and-load '("base/scode") '(COMPILER)) + (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY)))) + +;; Resyntax any files that need it. +((access syntax-files! (->environment '(COMPILER)))) + +;; Rebuild the package constructors and cref. +(cref/generate-constructors "comp") +(sf "comp.con" "comp.bcon") +(sf "comp.ldr" "comp.bldr") \ No newline at end of file diff --git a/v7/src/compiler/machines/C/cout.scm b/v7/src/compiler/machines/C/cout.scm new file mode 100644 index 000000000..1766427ab --- /dev/null +++ b/v7/src/compiler/machines/C/cout.scm @@ -0,0 +1,950 @@ +#| -*-Scheme-*- + +$Id: cout.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; C-output fake assembler and linker +;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +(define *C-procedure-name* 'DEFAULT) + +(define (stringify suffix initial-label lap-code info-output-pathname) + (define (stringify-object x) + (cond ((string? x) + x) + ((symbol? x) + (%symbol->string x)) + ((number? x) + (number->string x)) + (else + (error "stringify: Unknown frob" x)))) + + (define (make-time-stamp) + (let ((time (get-decoded-time))) + (string-append + "_" + (number->string (decoded-time/second time)) "_" + (number->string (decoded-time/minute time)) "_" + (number->string (decoded-time/hour time)) "_" + (number->string (decoded-time/day time)) "_" + (number->string (decoded-time/month time)) "_" + (number->string (decoded-time/year time))))) + + (define (->variable-declarations vars) + (if (null? vars) + (list "") + `("SCHEME_OBJECT\n\t " + ,(car vars) + ,@(append-map (lambda (var) + (list ",\n\t " var)) + (cdr vars)) + ";\n\t"))) + + (if *purification-root-object* + (define-object "PURIFICATION_ROOT" + (if (vector? (cdr *purification-root-object*)) + *purification-root-object* + (cons (car *purification-root-object*) + (list->vector + (reverse (cdr *purification-root-object*))))))) + + (define-object (special-label/debugging) + (let frob ((obj info-output-pathname)) + (cond ((pathname? obj) + (->namestring obj)) + ((pair? obj) + (cons (frob (car obj)) + (frob (cdr obj)))) + (else + obj)))) + + (define-object (special-label/environment) unspecific) + + (define (choose-proc-name default midfix time-stamp) + (let ((path (and info-output-pathname + (if (pair? info-output-pathname) + (car info-output-pathname) + info-output-pathname)))) + + (cond ((not *C-procedure-name*) + (string-append default suffix time-stamp)) + ((not (eq? *C-procedure-name* 'DEFAULT)) + (string-append *C-procedure-name* + midfix + suffix)) + ((not path) + (string-append default suffix time-stamp)) + (else + (string-append (car (last-pair (pathname-directory path))) + "_" + (pathname-name path) + midfix + suffix))))) + + (define (subroutine-information-1) + (cond ((eq? *invoke-interface* 'INFINITY) + (values (list "") (list ""))) + ((< *invoke-interface* 5) + (values (list-tail (list + "\ninvoke_interface_0:\n\tsubtmp_1 = 0;\n" + "\ninvoke_interface_1:\n\tsubtmp_2 = 0;\n" + "\ninvoke_interface_2:\n\tsubtmp_3 = 0;\n" + "\ninvoke_interface_3:\n\tsubtmp_4 = 0;\n" + "\ninvoke_interface_4:\n\t" + "INVOKE_INTERFACE_CODE ();\n") + *invoke-interface*) + (list "int subtmp_code;\n\t" + "long subtmp_1,subtmp_2,subtmp_3,subtmp_4;\n\t"))) + (else + (error "subroutine-information-1: Interface utilities take at most 4 arguments" + *invoke-interface*)))) + + (define (subroutine-information-2) + (if *used-invoke-primitive* + (values (list "\ninvoke_primitive:\n\t" + "INVOKE_PRIMITIVE_CODE ();") + (list "SCHEME_OBJECT primitive;\n\t" + "long primitive_nargs;\n\t")) + (values (list "") (list "")))) + + (define (subroutine-information) + (with-values subroutine-information-1 + (lambda (code-1 vars-1) + (with-values subroutine-information-2 + (lambda (code-2 vars-2) + (values (append code-1 code-2) + (append vars-1 vars-2))))))) + + (let ((n 1) ; First word is vector header + (initial-offset (label->offset initial-label))) + (with-values (lambda () (handle-labels n)) + (lambda (n label-defines label-dispatch label-block-initialization + symbol-table) + (with-values (lambda () (handle-free-refs-and-sets n)) + (lambda (n free-defines free-block-initialization free-symbols) + (with-values (lambda () (handle-objects n)) + (lambda (n decl-code xtra-procs object-prefix object-defines temp-vars + object-block-initialization) + (let* ((time-stamp (make-time-stamp)) + (code-name + (choose-proc-name "code" "" time-stamp)) + (block-name + (choose-proc-name "data" "_data" time-stamp)) + (decl-name (string-append "decl_" code-name))) + (with-values subroutine-information + (lambda (extra-code extra-variables) + (values + code-name + (cons* (cons (special-label/environment) + (-1+ n)) + (cons (special-label/debugging) + (- n 2)) + (append free-symbols symbol-table)) + (list-of-strings->string + (map (lambda (x) + (list-of-strings->string x)) + (list + (if (string-null? suffix) + (append + (file-prefix) + (list "DECLARE_COMPILED_CODE (\"" code-name + "\", " decl-name + ", " code-name ")\n\n")) + '()) + xtra-procs + + (if (string-null? suffix) + (append + (list "void\n" + "DEFUN_VOID (" decl-name ")\n{\n\t") + decl-code + (list "return;\n}\n\n")) + '()) + + label-defines + object-defines + free-defines + (list "\n") + + (list "#ifndef BAND_ALREADY_BUILT\n") + (cons "static " (function-header block-name)) + (list "SCHEME_OBJECT object = (ALLOCATE_VECTOR (" + (number->string (- n 1)) + "L));\n\t" + "SCHEME_OBJECT * current_block = " + "(OBJECT_ADDRESS (object));\n\t") + (->variable-declarations temp-vars) + (list "\n\t") + object-prefix + label-block-initialization + free-block-initialization + object-block-initialization + (list "return (current_block);") + (function-trailer block-name) + (list "#endif /* BAND_ALREADY_BUILT */\n") + (list "\n") + + (let ((header (function-header code-name))) + (if (string-null? suffix) + header + (cons "static " header))) + (function-decls) + (register-declarations) + extra-variables + (list + "goto perform_dispatch;\n\n" + (if *use-pop-return* + (string-append + "pop_return_repeat_dispatch:\n\n\t" + "POP_RETURN_REPEAT_DISPATCH();\n\n") + "") + "repeat_dispatch:\n\n\t" + "REPEAT_DISPATCH ();\n\n" + "perform_dispatch:\n\n\t" + "switch (LABEL_TAG (my_pc))\n\t" + "{\n\t case 0:\n" + "#ifndef BAND_ALREADY_BUILT\n\t\t" + "current_block = (" + block-name + " (my_pc));\n\t\t" + "return (¤t_block[" + (stringify-object initial-offset) + "]);\n" + "#else /* BAND_ALREADY_BUILT */\n\t\t" + "error_band_already_built ();\n" + "#endif /* BAND_ALREADY_BUILT */\n") + label-dispatch + (list + "\n\t default:\n\t\t" + "ERROR_UNKNOWN_DISPATCH (my_pc);\n\t}\n\t") + (map stringify-object lap-code) + extra-code + (function-trailer code-name)))))))))))))))) + +(define-integrable (list-of-strings->string strings) + (apply string-append strings)) + +(define-integrable (%symbol->string sym) + (system-pair-car sym)) + +(define (file-prefix) + (let ((time (get-decoded-time))) + (cons* "/* Emacs: this is properly parenthesized -*- C -*- code.\n" + " Thank God it was generated by a machine.\n" + " */\n\n" + "/* C code produced\n " + (decoded-time/date-string time) + " at " + (decoded-time/time-string time) + "\n by Liar version " + (let ((version false)) + (for-each-system! + (lambda (system) + (if (substring? "Liar" (system/name system)) + (set! version + (cons (system/version system) + (system/modification system)))) + unspecific)) + (if (not version) + "?.?" + (string-append (number->string (car version)) + "." + (number->string (cdr version))))) + ".\n */\n\n" + includes))) + +(define includes + (list "#include \"liarc.h\"\n\n")) + +(define (function-header name) + (list "SCHEME_OBJECT *\n" + "DEFUN (" + name + ", (my_pc), SCHEME_OBJECT * my_pc)\n" + "{\n\tREGISTER int current_C_proc = (LABEL_PROCEDURE (my_pc));\n\t")) + +(define (function-decls) + (list + "REGISTER SCHEME_OBJECT * current_block;\n\t" + "SCHEME_OBJECT * dynamic_link;\n\t" + "DECLARE_VARIABLES ();\n\n\t")) + +(define (function-trailer name) + (list "\n} /* End of " name ". */\n")) + +(define (make-define-statement symbol val) + (string-append "#define " (if (symbol? symbol) + (symbol->string symbol) + symbol) + " " + (if (number? val) + (number->string val) + val) + "\n")) + +;;;; Object constructors + +(define new-variables) +(define *subblocks*) +(define num) + +(define (generate-variable-name) + (set! new-variables + (cons (string-append "tmpObj" (number->string num)) + new-variables)) + (set! num (1+ num)) + (car new-variables)) + +(define-integrable (table/find table value) + ;; assv ? + (assq value table)) + +(define-integrable (guaranteed-fixnum? value) + (and (exact-integer? value) + (<= signed-fixnum/lower-limit value) + (< value signed-fixnum/upper-limit))) + +(define-integrable (guaranteed-long? value) + (and (exact-integer? value) + (<= guaranteed-long/lower-limit value) + (< value guaranteed-long/upper-limit))) + +(define trivial-objects + (list #f #t '() unspecific)) + +(define (trivial? object) + (or (memq object trivial-objects) + (guaranteed-fixnum? object))) + +(define (name-if-complicated node) + (cond ((fake-compiled-block? node) + (let ((name (fake-block/name node))) + (set! new-variables (cons name new-variables)) + name)) + ((or (%record? node) (vector? node)) + (generate-variable-name)) + (else + false))) + +(define (build-table nodes) + (map cdr + (sort (sort/enumerate + (list-transform-positive + (let loop ((nodes nodes) + (table '())) + (if (null? nodes) + table + (loop (cdr nodes) + (insert-in-table (car nodes) + table)))) + (lambda (pair) + (cdr pair)))) + (lambda (entry1 entry2) + (let ((obj1 (cadr entry1)) + (obj2 (cadr entry2))) + (if (not (fake-compiled-block? obj2)) + (or (fake-compiled-block? obj1) + (< (car entry1) (car entry2))) + (and (fake-compiled-block? obj1) + (< (fake-block/index obj1) + (fake-block/index obj2))))))))) + +;; Hack to make sort a stable sort + +(define (sort/enumerate l) + (let loop ((l l) (n 0) (l* '())) + (if (null? l) + l* + (loop (cdr l) + (1+ n) + (cons (cons n (car l)) + l*))))) + +(define (insert-in-table node table) + (cond ((trivial? node) + table) + ((table/find table node) + => (lambda (pair) + (if (not (cdr pair)) + (set-cdr! pair (generate-variable-name))) + table)) + (else + (let ((table + (cons (cons node (name-if-complicated node)) + table))) + + (define-integrable (do-vector-like node vlength vref) + (let loop ((table table) + (i (vlength node))) + (if (zero? i) + table + (let ((i-1 (-1+ i))) + (loop (insert-in-table (vref node i-1) + table) + i-1))))) + + (cond ((pair? node) + (insert-in-table + (car node) + (insert-in-table (cdr node) + table))) + ((vector? node) + (do-vector-like node vector-length vector-ref)) + ((or (fake-compiled-procedure? node) + (fake-compiled-block? node)) + table) + ((%record? node) + (do-vector-like node %record-length %record-ref)) + (else + ;; Atom + table)))))) + +(define (top-level-constructor object&name) + ;; (values prefix suffix) + (let ((name (cdr object&name)) + (object (car object&name))) + (cond ((pair? object) + (values '() + (list name " = (cons (SHARP_F, SHARP_F));\n\t"))) + ((fake-compiled-block? object) + (set! *subblocks* (cons object *subblocks*)) + (values (list name " = (initialize_subblock (\"" + (fake-block/c-proc object) + "\"));\n\t") + '())) + ((fake-compiled-procedure? object) + (values '() + (list name " = " + (compiled-procedure-constructor + object) + ";\n\t"))) + ((vector? object) + (values '() + (list name " = (ALLOCATE_VECTOR (" + (number->string (vector-length object)) + "));\n\t"))) + ((%record? object) + (values '() + (list name " = (ALLOCATE_RECORD (" + (number->string (%record-length object)) + "));\n\t"))) + (else + (values '() + (list name "\n\t = " + (->simple-C-object object) + ";\n\t")))))) + +(define (top-level-updator object&name table) + (let ((name (cdr object&name)) + (object (car object&name))) + + (define-integrable (do-vector-like object vlength vref vset-name) + (let loop ((i (vlength object)) + (code '())) + (if (zero? i) + code + (let ((i-1 (- i 1))) + (loop i-1 + `(,vset-name " (" ,name ", " + ,(number->string i-1) ", " + ,(constructor (vref object i-1) + table) + ");\n\t" + ,@code)))))) + + (cond ((pair? object) + (list "SET_PAIR_CAR (" name ", " + (constructor (car object) table) ");\n\t" + "SET_PAIR_CDR (" name ", " + (constructor (cdr object) table) ");\n\t")) + ((or (fake-compiled-block? object) + (fake-compiled-procedure? object)) + '("")) + ((%record? object) + (do-vector-like object %record-length %record-ref "RECORD_SET")) + ((vector? object) + (do-vector-like object vector-length vector-ref "VECTOR_SET")) + (else + '(""))))) + +(define (constructor object table) + (let process ((object object)) + (cond ((table/find table object) => cdr) + ((pair? object) + (cond ((or (not (pair? (cdr object))) + (table/find table (cdr object))) + (string-append "(CONS (" (process (car object)) ", " + (process (cdr object)) "))")) + (else + (let loop ((npairs 0) + (object object) + (frobs '())) + (if (and (pair? object) (not (table/find table object))) + (loop (1+ npairs) + (cdr object) + (cons (car object) frobs)) + ;; List is reversed to call rconsm + (string-append + "(RCONSM (" (number->string (1+ npairs)) + (apply string-append + (map (lambda (frob) + (string-append ", " + (process frob))) + (cons object frobs))) + "))")))))) + ((fake-compiled-procedure? object) + (compiled-procedure-constructor object)) + ((or (fake-compiled-block? object) + (vector? object) + (%record? object)) + (error "constructor: Can't build directly" + object)) + (else + (->simple-C-object object))))) + +(define (compiled-procedure-constructor object) + (string-append "(CC_BLOCK_TO_ENTRY (" + (fake-procedure/block-name object) + ", " + (number->string + (fake-procedure/label-index object)) + "))")) + +(define (top-level-constructors table) + ;; (values prefix suffix) + ;; (append-map top-level-constructor table) + (let loop ((table (reverse table)) (prefix '()) (suffix '())) + (if (null? table) + (values prefix suffix) + (with-values (lambda () (top-level-constructor (car table))) + (lambda (prefix* suffix*) + (loop (cdr table) + (append prefix* prefix) + (append suffix* suffix))))))) + +(define (->constructors names objects) + ;; (values prefix-code suffix-code) + (let* ((table (build-table objects))) + (with-values (lambda () (top-level-constructors table)) + (lambda (prefix suffix) + (values prefix + (append suffix + (append-map (lambda (object&name) + (top-level-updator object&name table)) + table) + (append-map + (lambda (name object) + (list (string-append name "\n\t = " + (constructor object table) + ";\n\t"))) + names + objects))))))) + +(define char-set:C-char-quoted + (char-set #\\ #\" #\')) + +(define char-set:C-string-quoted + (char-set #\\ #\" #\Tab #\VT #\BS #\Linefeed #\Return #\Page #\BEL)) + +(define (C-quotify string) + (let ((index (string-find-next-char-in-set string char-set:C-string-quoted))) + (if (not index) + string + (let ((new (write-to-string string))) + (substring new 1 (-1+ (string-length new))))))) + +(define (C-quotify-char char) + (cond ((not (char-set-member? char-set:graphic char)) + (cond ((char=? char #\NUL) + "'\\0'") + ((char-set-member? char-set:C-string-quoted char) + (string-append + "'" + (let ((s (write-to-string (make-string 1 char)))) + (substring s 1 (-1+ (string-length s)))) + "'")) + (else + (string-append + "'\\" + (let ((s (number->string (char-code char) 8))) + (if (< (string-length s) 3) + (string-append (make-string (- 3 (string-length s)) #\0) + s) + s)) + "'")))) + ((char-set-member? char-set:C-char-quoted char) + (string-append "'\\" (make-string 1 char) "'")) + (else + (string-append "'" (make-string 1 char) "'")))) + +(define (->simple-C-object object) + (cond ((symbol? object) + (let ((name (symbol->string object))) + (string-append "(C_SYM_INTERN (" + (number->string (string-length name)) + "L, \"" (C-quotify name) "\"))"))) + ((string? object) + (string-append "(C_STRING_TO_SCHEME_STRING (" + (number->string (string-length object)) + "L, \"" (C-quotify object) "\"))")) + ((number? object) + (let process ((number object)) + (cond ((flo:flonum? number) + (string-append "(DOUBLE_TO_FLONUM (" + (number->string number) "))")) + ((guaranteed-long? number) + (string-append "(LONG_TO_INTEGER (" + (number->string number) "L))")) + ((exact-integer? number) + (let ((bignum-string + (number->string (if (negative? number) + (- number) + number) + 16))) + (string-append "(DIGIT_STRING_TO_INTEGER (" + (if (negative? number) + "true, " + "false, ") + (number->string + (string-length bignum-string)) + "L, \"" bignum-string "\"))"))) + ((and (exact? number) (rational? number)) + (string-append "(MAKE_RATIO (" + (process (numerator number)) + ", " (process (denominator number)) + "))")) + ((and (complex? number) (not (real? number))) + (string-append "(MAKE_COMPLEX (" + (process (real-part number)) + ", " (process (imag-part number)) + "))")) + (else + (error "scheme->C-object: Unknown number" number))))) + ((eq? #f object) + "SHARP_F") + ((eq? #t object) + "SHARP_T") + ((null? object) + "NIL") + ((eq? object unspecific) + "UNSPECIFIC") + ((primitive-procedure? object) + (let ((arity (primitive-procedure-arity object))) + (if (< arity -1) + (error "scheme->C-object: Unknown arity primitive" object) + (string-append "(MAKE_PRIMITIVE_PROCEDURE (\"" + (symbol->string + (primitive-procedure-name object)) + "\", " + (number->string arity) + "))")))) + ((char? object) + (string-append "(MAKE_CHAR (" + (let ((bits (char-bits object))) + (if (zero? bits) + "0" + (string-append "0x" (number->string bits 16)))) + ", ((unsigned) " + (C-quotify-char (make-char (char-code object) 0)) + ")))")) + ((bit-string? object) + (let ((string (number->string (bit-string->unsigned-integer object) + 16))) + (string-append "(DIGIT_STRING_TO_BIT_STRING (" + (number->string (bit-string-length object)) "L, " + (number->string (string-length string)) "L, \"" + (string-reverse string) + "\"))"))) + ;; Note: The following are here because of the Scode interpreter + ;; and the runtime system. + ;; They are not necessary for ordinary code. + ((interpreter-return-address? object) + (string-append "(MAKE_OBJECT (TC_RETURN_CODE, 0x" + (number->string (object-datum object) 16) + "))")) + (else + (error "->simple-C-object: unrecognized-type" + object)))) + +(define (string-reverse string) + (let* ((len (string-length string)) + (res (make-string len))) + (do ((i (fix:- len 1) (fix:- i 1)) + (j 0 (fix:+ j 1))) + ((fix:= j len) res) + (string-set! res i (string-ref string j))))) + +(define (handle-objects n) + ;; All the reverses produce the correct order in the output block. + ;; The incoming objects are reversed + ;; (environment, debugging label, purification root, etc.) + + (fluid-let ((new-variables '()) + (*subblocks* '()) + (num 0)) + + (define (iter n table names defines objects) + (if (null? table) + (with-values + (lambda () (->constructors (reverse names) + (reverse objects))) + (lambda (prefix suffix) + (values n + (map fake-block->decl *subblocks*) + (append-map fake-block->c-code *subblocks*) + prefix + defines + new-variables + suffix))) + (let ((entry (car table))) + (iter (1+ n) + (cdr table) + (cons (string-append "current_block[" + (entry-label entry) "]") + names) + (cons (make-define-statement (entry-label entry) n) + defines) + (cons (entry-value entry) + objects))))) + + (iter n (reverse (table->list-of-entries objects)) '() '() '()))) + +(define (handle-free-refs-and-sets start-offset) + ;; process free-uuo-links free-references free-assignments global-uuo-links + ;; return n defines initialization + + (define (make-linkage-section-header start kind count) + (string-append "current_block[" (number->string start) + "L] = (MAKE_LINKER_HEADER (" kind + ", " (number->string count) "));\n\t")) + + (define (insert-symbol label symbol) + (let ((name (symbol->string symbol))) + (string-append "current_block[" label + "] = (C_SYM_INTERN (" + (number->string (string-length name)) + ", \"" name "\"));\n\t"))) + + (define (process-links start links kind) + (if (null? (cdr links)) + (values start 0 '() '()) + (let process ((count 0) + (links (cdr links)) + (offset (+ start 1)) + (defines '()) + (inits '())) + (cond ((null? links) + (values offset + 1 + (reverse defines) + (cons (make-linkage-section-header start kind count) + (reverse inits)))) + ((null? (cdr (car links))) + (process count (cdr links) offset defines inits)) + (else + (let ((entry (cadar links))) + (let ((name (caar links)) + (arity (car entry)) + (symbol (cdr entry))) + (process (1+ count) + (cons (cons (caar links) (cddar links)) + (cdr links)) + (+ offset 2) + (cons (make-define-statement symbol offset) + defines) + (cons (string-append + (insert-symbol symbol name) + "current_block[" + symbol + " + 1] = ((SCHEME_OBJECT) (" + (number->string arity) "));\n\t") + inits))))))))) + + (define (process-table start table kind) + (define (iter n table defines inits) + (if (null? table) + (values n + 1 + (reverse defines) + (cons (make-linkage-section-header start kind + (- n (+ start 1))) + (reverse inits))) + (let ((symbol (entry-label (car table)))) + (iter (1+ n) + (cdr table) + (cons (make-define-statement symbol n) + defines) + (cons (insert-symbol symbol (entry-value (car table))) + inits))))) + + (if (null? table) + (values start 0 '() '()) + (iter (1+ start) table '() '()))) + + (with-values + (lambda () (process-links start-offset free-uuo-links + "OPERATOR_LINKAGE_KIND")) + (lambda (offset uuos? uuodef uuoinit) + (with-values + (lambda () + (process-table offset + (table->list-of-entries free-references) + "REFERENCE_LINKAGE_KIND")) + (lambda (offset refs? refdef refinit) + (with-values + (lambda () + (process-table offset + (table->list-of-entries free-assignments) + "ASSIGNMENT_LINKAGE_KIND")) + (lambda (offset asss? assdef assinit) + (with-values + (lambda () (process-links offset global-uuo-links + "GLOBAL_OPERATOR_LINKAGE_KIND")) + (lambda (offset glob? globdef globinit) + (let ((free-references-sections (+ uuos? refs? asss? glob?))) + (values + offset + (append + uuodef refdef assdef globdef + (list + (make-define-statement + (special-label/free-references) + start-offset) + (make-define-statement + (special-label/number-of-sections) + free-references-sections))) + (append uuoinit refinit assinit globinit) + (list (cons (special-label/free-references) + start-offset) + (cons (special-label/number-of-sections) + free-references-sections))))))))))))) + +(define (handle-labels n) + (define (iter offset tagno labels label-defines + label-dispatch label-block-initialization + label-bindings) + (if (null? labels) + (values (- offset 1) + (reverse label-defines) + (reverse label-dispatch) + (cons (string-append + "current_block[" + (number->string n) + "L] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, " + (number->string (- (- offset 1) (+ n 1))) + "));\n\t") + (reverse label-block-initialization)) + label-bindings) + (let* ((label-data (car labels)) + (a-symbol (or (symbol-1 label-data) + (symbol-2 label-data)))) + (iter (+ offset 2) + (+ tagno 1) + (cdr labels) + (cons (string-append + (make-define-statement a-symbol offset) + (let ((other-symbol (or (symbol-2 label-data) + (symbol-1 label-data)))) + (if (eq? other-symbol a-symbol) + "" + (make-define-statement other-symbol a-symbol))) + (if (dispatch-1 label-data) + (make-define-statement (dispatch-1 label-data) + tagno) + "") + (if (dispatch-2 label-data) + (make-define-statement (dispatch-2 label-data) + tagno) + "")) + label-defines) + (cons (string-append + "\n\t case " + (number->string tagno) ":\n\t\t" + "current_block = (my_pc - " a-symbol ");\n\t\t" + "goto " + (symbol->string (or (label-1 label-data) + (label-2 label-data))) + ";\n") + label-dispatch) + (cons (string-append + "WRITE_LABEL_DESCRIPTOR(¤t_block[" + a-symbol "], 0x" + (number->string (code-word-sel label-data) 16) + ", " a-symbol ");\n\t" + "current_block [" a-symbol + "] = (MAKE_LABEL_WORD (current_C_proc, " + (number->string tagno) + "));\n\t") + label-block-initialization) + (append + (if (label-1 label-data) + (list (cons (label-1 label-data) offset)) + '()) + (if (label-2 label-data) + (list (cons (label-2 label-data) offset)) + '()) + label-bindings))))) + + (iter (+ 2 n) 1 (reverse! labels) '() '() '() '())) + +(define-structure (fake-compiled-procedure + (constructor make-fake-compiled-procedure) + (conc-name fake-procedure/)) + (block-name false read-only true) + (label-index false read-only true)) + +(define-structure (fake-compiled-block + (constructor make-fake-compiled-block) + (conc-name fake-block/)) + (name false read-only true) + (c-proc false read-only true) + (c-code false read-only true) + (index false read-only true)) + +(define fake-compiled-block-name-prefix "ccBlock") + +(define (fake-compiled-block-name number) + (string-append fake-compiled-block-name-prefix + "_" (number->string (-1+ number)))) + +(define (fake-block->decl block) + (string-append "declare_compiled_code (\"" + (fake-block/c-proc block) + "\", NO_SUBBLOCKS, " + (fake-block/c-proc block) + ");\n\t")) + +(define (fake-block->c-code block) + (list (fake-block/c-code block) + "\f\n")) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm new file mode 100644 index 000000000..d4cf5d4ae --- /dev/null +++ b/v7/src/compiler/machines/C/ctop.scm @@ -0,0 +1,341 @@ +#| -*-Scheme-*- + +$Id: ctop.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; C-output fake assembler and linker +;;; package: (compiler top-level) + +(declare (usual-integrations)) + +;;;; Exports to the compiler + +(define c-code-tag (string->symbol "#[C-code]")) + +(define (compiler-file-output object pathname) + (let ((pair (vector-ref object 1))) + (call-with-output-file (pathname-new-type pathname "c") + (lambda (port) + (write-string (cdr pair) port))) + (fasdump (cons c-code-tag (car pair)) + pathname))) + +(define (compiled-scode->procedure compiled-scode environment) + environment ; ignored + (error "compiled-scode->procedure: Not yet implemented" + compiled-scode)) + +(define (cross-compile-bin-file input . more) + input more ; ignored + (error "cross-compile-bin-file: Meaningless")) + +(define (optimize-linear-lap lap-program) + lap-program) + +(define (recursive-compilation-results) + (sort *recursive-compilation-results* + (lambda (x y) + (< (vector-ref x 0) + (vector-ref y 0))))) + +;; Global variables for assembler and linker + +(define *recursive-compilation-results*) + +;; First set: phase/rtl-generation +;; Last used: phase/link +(define *block-label*) +(define *disambiguator*) + +(define *start-label*) + +;; First set: phase/lap-generation +;; Last used: phase/info-generation-2 +(define *external-labels*) +(define *special-labels*) + +;; First set: phase/lap-generation +;; Last used: phase/output-generation ??? +(define *invoke-interface*) +(define *used-invoke-primitive*) +(define *use-jump-execute-chache*) +(define *use-pop-return*) +(define *purification-root-object*) + +;; First set: phase/assemble +;; Last used: phase/output-generation +(define *C-proc-name*) +(define *labels*) +(define *code*) + +;; First set: phase/output-generation +(define *result*) + +(define (assemble&link info-output-pathname) + (phase/assemble info-output-pathname) + (if info-output-pathname + (phase/info-generation-2 *labels* info-output-pathname)) + (phase/output-generation) + *result*) + +(define (wrap-lap entry-label some-lap) + (set! *start-label* entry-label) + (LAP ,@(if *procedure-result?* + (LAP) + (lap:make-entry-point entry-label *block-label*)) + ,@some-lap)) + +(define (bind-assembler&linker-top-level-variables thunk) + (fluid-let ((*recursive-compilation-results* '())) + (thunk))) + +(define (bind-assembler&linker-variables thunk) + (fluid-let ((current-register-list) + (free-assignments) + (free-references) + (free-uuo-links) + (global-uuo-links) + (label-num) + (labels) + (objects) + (permanent-register-list) + (*block-label*) + (*disambiguator*) + (*start-label*) + (*external-labels*) + (*special-labels*) + (*invoke-interface*) + (*used-invoke-primitive*) + (*use-jump-execute-chache*) + (*use-pop-return*) + (*purification-root-object*) + (*end-of-block-code*) + (*C-proc-name*) + (*labels*) + (*code*)) + (thunk))) + +(define (assembler&linker-reset!) + (set! *recursive-compilation-results* '()) + (set! current-register-list) + (set! free-assignments) + (set! free-references) + (set! free-uuo-links) + (set! global-uuo-links) + (set! label-num) + (set! labels) + (set! objects) + (set! permanent-register-list) + (set! *block-label*) + (set! *disambiguator*) + (set! *start-label*) + (set! *external-labels*) + (set! *special-labels*) + (set! *invoke-interface*) + (set! *used-invoke-primitive*) + (set! *use-jump-execute-chache*) + (set! *use-pop-return*) + (set! *purification-root-object*) + (set! *end-of-block-code*) + (set! *C-proc-name*) + (set! *labels*) + (set! *code*) + unspecific) + +(define (initialize-back-end!) + (set! current-register-list '()) + (set! free-assignments (make-table)) + (set! free-references (make-table)) + (set! free-uuo-links (list 'FOO)) + (set! global-uuo-links (list 'BAR)) + (set! label-num 0) + (set! labels '()) + (set! objects (make-table)) + (set! permanent-register-list '()) + (set! *block-label* (generate-label)) + (set! *disambiguator* + (if (zero? *recursive-compilation-number*) + "" + (string-append (number->string *recursive-compilation-number*) + "_"))) + (set! *external-labels* '()) + (set! *special-labels* (make-special-labels)) + (set! *invoke-interface* 'INFINITY) + (set! *used-invoke-primitive* false) + (set! *use-jump-execute-chache* false) + (set! *use-pop-return* false) + (set! *purification-root-object* false) + (set! *end-of-block-code* (LAP)) + unspecific) + +(define (phase/assemble pathname) + (compiler-phase + "Pseudo-Assembly" ; garbage collection + (lambda () + (with-values + (lambda () + (stringify + (if (eq? pathname 'RECURSIVE) + (string-append "_" + (number->string *recursive-compilation-number*)) + "") + (last-reference *start-label*) + (last-reference *lap*) + (if (eq? pathname 'RECURSIVE) + (cons *info-output-filename* + *recursive-compilation-number*) + pathname))) + (lambda (proc-name labels code) + (set! *C-proc-name* proc-name) + (set! *labels* labels) + (set! *code* code) + unspecific))))) + +(define (phase/output-generation) + (if (not (null? *ic-procedure-headers*)) + (error "phase/output-generation: Can't hack IC procedures")) + + (set! *result* + (if *procedure-result?* + (let* ((linking-info *subprocedure-linking-info*) + (translate-label + (lambda (label) + (let ((place (assq label *labels*))) + (if (not place) + (error "translate-label: Not found" label) + (cdr place))))) + (translate-symbol + (lambda (index) + (translate-label (vector-ref linking-info index)))) + (index *recursive-compilation-number*) + (name (fake-compiled-block-name index))) + (cons (make-fake-compiled-procedure + name + (translate-label *entry-label*)) + (vector + (make-fake-compiled-block name + *C-proc-name* + *code* + index) + (translate-symbol 0) + (translate-symbol 1) + (translate-symbol 2)))) + (cons *C-proc-name* + *code*))) + + (if (not compiler:preserve-data-structures?) + (begin + (set! *subprocedure-linking-info*) + (set! *labels*) + (set! *block-label*) + (set! *entry-label*) + (set! *ic-procedure-headers*) + (set! *code*) + unspecific))) + +(define (phase/info-generation-2 labels pathname) + (info-generation-2 labels pathname)) + +(define (info-generation-2 labels pathname) + (compiler-phase "Debugging Information Generation" + (lambda () + (let ((info + (info-generation-phase-3 + (last-reference *dbg-expression*) + (last-reference *dbg-procedures*) + (last-reference *dbg-continuations*) + labels + (last-reference *external-labels*)))) + (cond ((eq? pathname 'KEEP) ; for dynamic execution + info) + ((eq? pathname 'RECURSIVE) ; recursive compilation + (set! *recursive-compilation-results* + (cons (vector *recursive-compilation-number* + info + false) + *recursive-compilation-results*)) + unspecific) + (else + (compiler:dump-info-file + (let ((others (recursive-compilation-results))) + (if (null? others) + info + (list->vector + (cons info + (map (lambda (other) (vector-ref other 1)) + others))))) + pathname) + *info-output-filename*)))))) + +(define (compiler:dump-bci-file binf pathname) + (load-option 'COMPRESS) + (let ((bci-path (pathname-new-type pathname "bci"))) + (split-inf-structure! binf false) + (call-with-temporary-filename + (lambda (bif-name) + (fasdump binf bif-name true) + (compress bif-name bci-path))) + (announce-info-files bci-path))) + +(define (announce-info-files . files) + (if compiler:noisy? + (let ((port (nearest-cmdl/port))) + (let loop ((files files)) + (if (null? files) + unspecific + (begin + (fresh-line port) + (write-string ";") + (write (->namestring (car files))) + (write-string " dumped ") + (loop (cdr files)))))))) + +(define compiler:dump-info-file compiler:dump-bci-file) + +;; This defintion exported to compiler to handle losing C name restrictions + +(define (canonicalize-label-name prefix) + (if (string-null? prefix) + "empty_string" + (let* ((str (if (char-alphabetic? (string-ref prefix 0)) + (string-copy prefix) + (string-append "Z_" prefix))) + (len (string-length str))) + (do ((i 0 (1+ i))) + ((>= i len) str) + (let ((char (string-ref str i))) + (if (not (char-alphanumeric? char)) + (string-set! str i + (case char + ((#\?) #\P) + ((#\!) #\B) + (else #\_))))))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/cutl.scm b/v7/src/compiler/machines/C/cutl.scm new file mode 100644 index 000000000..3102f2ac7 --- /dev/null +++ b/v7/src/compiler/machines/C/cutl.scm @@ -0,0 +1,137 @@ +#| -*-Scheme-*- + +$Id: cutl.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; C back-end utilities +;;; package: (compiler) + +(declare (usual-integrations)) + +(define (->back-end-number x) + (if (number? x) + (number->string x) + x)) + +(define (back-end:= x y) + (cond ((and (number? x) (number? y)) + (= x y)) + (else + (equal? x y)))) + +(define (back-end:+ x y) + (cond ((and (number? x) (number? y)) + (+ x y)) + ((and (number? y) (= y 0)) + x) + ((and (number? x) (= x 0)) + y) + (else + (string-append "(" + (->back-end-number x) + " + " + (->back-end-number y) + ")")))) + +(define (back-end:- x y) + (cond ((and (number? x) (number? y)) + (- x y)) + ((and (number? y) (= y 0)) + x) + ((equal? x y) + 0) + (else + (string-append "(" + (->back-end-number x) + " - " + (->back-end-number y) + ")")))) + +(define (back-end:* x y) + (cond ((and (number? x) (number? y)) + (* x y)) + ((and (number? y) (= y 1)) + x) + ((and (number? y) (= y 0)) + 0) + ((and (number? x) (= x 1)) + y) + ((and (number? x) (= x 0)) + 0) + (else + (string-append "(" + (->back-end-number x) + " * " + (->back-end-number y) + ")")))) + +(define (back-end:quotient x y) + (cond ((and (number? x) (number? y)) + (quotient x y)) + ((and (number? y) (= y 1)) + x) + ((and (number? x) (= x 0)) + 0) + ((equal? x y) + 1) + (else + (string-append "(" + (->back-end-number x) + " / " + (->back-end-number y) + ")")))) + +(define (back-end:expt x y) + (cond ((and (number? x) (number? y)) + (expt x y)) + ((and (number? x) + (or (= x 0) (= x 1))) + x) + ((and (number? y) (= y 0)) + 1) + ((and (number? y) (= y 1)) + x) + ((and (number? x) (= x 2)) + (string-append "(1 << " + (->back-end-number y) + ")")) + (else + (error "back-end:expt: Cannot exponentiate" + x y)))) + +;; This is a lie, but it is used only in places where false is the +;; correct default. + +(define (back-end:< x y) + (and (number? x) + (number? y) + (< x y))) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/decls.scm b/v7/src/compiler/machines/C/decls.scm new file mode 100644 index 000000000..520b3f557 --- /dev/null +++ b/v7/src/compiler/machines/C/decls.scm @@ -0,0 +1,617 @@ +#| -*-Scheme-*- + +$Id: decls.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler File Dependencies +;;; package: (compiler declarations) + +(declare (usual-integrations)) + +(define (initialize-package!) + (add-event-receiver! event:after-restore reset-source-nodes!) + (reset-source-nodes!)) + +(define (reset-source-nodes!) + (set! source-filenames '()) + (set! source-hash) + (set! source-nodes) + (set! source-nodes/by-rank) + unspecific) + +(define (maybe-setup-source-nodes!) + (if (null? source-filenames) + (setup-source-nodes!))) + +(define (setup-source-nodes!) + (let ((filenames + (append-map! + (lambda (subdirectory) + (map (lambda (pathname) + (string-append subdirectory + "/" + (pathname-name pathname))) + (directory-read + (string-append subdirectory + "/" + source-file-expression)))) + '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt" + "machines/C")))) + (if (null? filenames) + (error "Can't find source files of compiler")) + (set! source-filenames filenames)) + (set! source-hash + (make/hash-table + 101 + string-hash-mod + (lambda (filename source-node) + (string=? filename (source-node/filename source-node))) + make/source-node)) + (set! source-nodes + (map (lambda (filename) + (hash-table/intern! source-hash + filename + identity-procedure + identity-procedure)) + source-filenames)) + (initialize/syntax-dependencies!) + (initialize/integration-dependencies!) + (initialize/expansion-dependencies!) + (source-nodes/rank!)) + +(define source-file-expression "*.scm") +(define source-filenames) +(define source-hash) +(define source-nodes) +(define source-nodes/by-rank) + +(define (filename/append directory . names) + (map (lambda (name) (string-append directory "/" name)) names)) + +(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)) + unspecific) + +(define (compute-dependencies! nodes) + (for-each (lambda (node) + (set-source-node/dependencies! + node + (list-transform-negative (source-node/backward-closure node) + (lambda (node*) + (memq node (source-node/backward-closure node*))))) + (set-source-node/dependents! + node + (list-transform-negative (source-node/forward-closure node) + (lambda (node*) + (memq node (source-node/forward-closure node*)))))) + nodes)) + +(define (compute-ranks! nodes) + (let loop ((nodes nodes) (unranked-nodes '())) + (if (null? nodes) + (if (not (null? unranked-nodes)) + (loop unranked-nodes '())) + (loop (cdr nodes) + (let ((node (car nodes))) + (let ((rank (source-node/rank* node))) + (if rank + (begin + (set-source-node/rank! node rank) + unranked-nodes) + (cons node unranked-nodes)))))))) + +(define (source-node/rank* node) + (let loop ((nodes (source-node/dependencies node)) (rank -1)) + (if (null? nodes) + (1+ rank) + (let ((rank* (source-node/rank (car nodes)))) + (and rank* + (loop (cdr nodes) (max rank rank*))))))) + +(define (source-nodes/sort-by-rank nodes) + (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y))))) + +;;;; 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" + "toplev" ; "asstop" "crstop" + "blocks" "cfg1" "cfg2" "cfg3" "constr" + "contin" "ctypes" "debug" "enumer" + "infnew" "lvalue" "object" "pmerly" "proced" + "refctx" "rvalue" "scode" "sets" "subprb" + "switch" "utils") + (filename/append "back" + "insseq" "lapgn1" "lapgn2" "linear" "regmap") + (filename/append "machines/C" + "cout" "ctop" "machin" "rulrew" "rgspcm") + (filename/append "fggen" + "declar" "fggen" "canon") + (filename/append "fgopt" + "blktyp" "closan" "conect" "contan" "delint" + "desenv" "envopt" "folcon" "offset" "operan" + "order" "outer" "param" "reord" "reteqv" "reuse" + "sideff" "simapp" "simple" "subfre" "varind") + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" + "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2" + "valclass") + (filename/append "rtlgen" + "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" + "rgretn" "rgrval" "rgstmt" "rtlgen") + (filename/append "rtlopt" + "ralloc" "rcompr" "rcse1" "rcse2" "rcseep" + "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow" + "rerite" "rinvex" "rlife" "rtlcsm")) + compiler-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/C" + "lapgen" + "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo" "cout") + lap-generator-syntax-table))) + +;;;; Integration Dependencies + +(define (initialize/integration-dependencies!) + + (define (add-declaration! declaration filenames) + (for-each (lambda (filenames) + (let ((node (filename->source-node filenames))) + (set-source-node/declarations! + node + (cons declaration + (source-node/declarations node))))) + filenames)) + + (let* ((front-end-base + (filename/append "base" + "blocks" "cfg1" "cfg2" "cfg3" + "contin" "ctypes" "enumer" "lvalue" + "object" "proced" "rvalue" + "scode" "subprb" "utils")) + (C-base + (filename/append "machines/C" "machin")) + (rtl-base + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlobj" + "rtlreg" "rtlty1" "rtlty2")) + (cse-base + (filename/append "rtlopt" + "rcse1" "rcseht" "rcserq" "rcsesr")) + (cse-all + (append (filename/append "rtlopt" + "rcse2" "rcseep") + cse-base)) + (instruction-base + (filename/append "machines/C" "machin")) + (lapgen-base + (append (filename/append "back" "linear" "regmap") + (filename/append "machines/C" "lapgen"))) + (lapgen-body + (append + (filename/append "back" "lapgn1" "lapgn2") + (filename/append "machines/C" + "rules1" "rules2" "rules3" "rules4" + "rulfix" "rulflo" "cout" + )))) + + (define (file-dependency/integration/join filenames dependencies) + (for-each (lambda (filename) + (file-dependency/integration/make filename dependencies)) + filenames)) + + (define (file-dependency/integration/make filename dependencies) + (let ((node (filename->source-node filename))) + (for-each (lambda (dependency) + (let ((node* (filename->source-node dependency))) + (if (not (eq? node node*)) + (source-node/link! node node*)))) + dependencies))) + + (define (define-integration-dependencies directory name directory* . names) + (file-dependency/integration/make + (string-append directory "/" name) + (apply filename/append directory* names))) + + (define-integration-dependencies "base" "object" "base" "enumer") + (define-integration-dependencies "base" "enumer" "base" "object") + (define-integration-dependencies "base" "utils" "base" "scode") + (define-integration-dependencies "base" "cfg1" "base" "object") + (define-integration-dependencies "base" "cfg2" "base" + "cfg1" "cfg3" "object") + (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2") + (define-integration-dependencies "base" "ctypes" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb") + (define-integration-dependencies "base" "rvalue" "base" + "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils") + (define-integration-dependencies "base" "lvalue" "base" + "blocks" "object" "proced" "rvalue" "utils") + (define-integration-dependencies "base" "blocks" "base" + "enumer" "lvalue" "object" "proced" "rvalue" "scode") + (define-integration-dependencies "base" "proced" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object" + "rvalue" "utils") + (define-integration-dependencies "base" "contin" "base" + "blocks" "cfg3" "ctypes") + (define-integration-dependencies "base" "subprb" "base" + "cfg3" "contin" "enumer" "object" "proced") + + (define-integration-dependencies "machines/C" "machin" "rtlbase" + "rtlreg" "rtlty1" "rtlty2") + + (define-integration-dependencies "rtlbase" "regset" "base") + (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2") + (define-integration-dependencies "rtlbase" "rgraph" "machines/C" + "machin") + (define-integration-dependencies "rtlbase" "rtlcfg" "base" + "cfg1" "cfg2" "cfg3") + (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils") + (define-integration-dependencies "rtlbase" "rtlcon" "machines/C" + "machin") + (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" + "rtlreg" "rtlty1") + (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2") + (define-integration-dependencies "rtlbase" "rtline" "rtlbase" + "rtlcfg" "rtlty2") + (define-integration-dependencies "rtlbase" "rtlobj" "base" + "cfg1" "object" "utils") + (define-integration-dependencies "rtlbase" "rtlreg" "machines/C" + "machin") + (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase" + "rgraph" "rtlty1") + (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg") + (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode") + (define-integration-dependencies "rtlbase" "rtlty2" "machines/C" + "machin") + (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1") + + (file-dependency/integration/join + (append + (filename/append "base" "refctx") + (filename/append "fggen" + "declar" "fggen") ; "canon" needs no integrations + (filename/append "fgopt" + "blktyp" "closan" "conect" "contan" "delint" "desenv" + "envopt" "folcon" "offset" "operan" "order" "param" + "outer" "reuse" "reteqv" "sideff" "simapp" "simple" + "subfre" "varind")) + (append C-base front-end-base)) + + (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord") + + (file-dependency/integration/join + (filename/append "rtlgen" + "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn" + "rgrval" "rgstmt" "rtlgen") + (append C-base front-end-base rtl-base)) + + (file-dependency/integration/join + (append cse-all + (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow" + "rerite" "rinvex" "rlife" "rtlcsm") + (filename/append "machines/C" "rulrew")) + (append C-base rtl-base)) + + (file-dependency/integration/join cse-all cse-base) + + (file-dependency/integration/join + (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife") + (filename/append "rtlbase" "regset")) + + (file-dependency/integration/join + (filename/append "rtlopt" "rcseht" "rcserq") + (filename/append "base" "object")) + + (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2") + + (let ((dependents + (append instruction-base + lapgen-base + lapgen-body + (filename/append "back" "linear")))) + (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents) + (file-dependency/integration/join dependents instruction-base)) + + (file-dependency/integration/join (append lapgen-base lapgen-body) + lapgen-base) + + (define-integration-dependencies "back" "lapgn1" "base" + "cfg1" "cfg2" "utils") + (define-integration-dependencies "back" "lapgn1" "rtlbase" + "regset" "rgraph" "rtlcfg") + (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg") + (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2") + (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg") + (define-integration-dependencies "back" "mermap" "back" "regmap") + (define-integration-dependencies "back" "regmap" "base" "utils")) + + (for-each (lambda (node) + (let ((links (source-node/backward-links node))) + (if (not (null? links)) + (set-source-node/declarations! + node + (cons (make-integration-declaration + (source-node/pathname node) + (map source-node/pathname links)) + (source-node/declarations node)))))) + source-nodes)) + +(define (make-integration-declaration pathname integration-dependencies) + `(INTEGRATE-EXTERNAL + ,@(map (let ((default + (make-pathname + false + false + (cons 'RELATIVE + (make-list + (length (cdr (pathname-directory pathname))) + 'UP)) + false + false + false))) + (lambda (pathname) + (merge-pathnames pathname default))) + integration-dependencies))) + +(define-integrable (integration-declaration? declaration) + (eq? (car declaration) 'INTEGRATE-EXTERNAL)) + +;;;; Expansion Dependencies + +(define (initialize/expansion-dependencies!) + (let ((file-dependency/expansion/join + (lambda (filenames expansions) + (for-each (lambda (filename) + (let ((node (filename->source-node filename))) + (set-source-node/declarations! + node + (cons (make-expansion-declaration expansions) + (source-node/declarations node))))) + filenames)))) + (file-dependency/expansion/join + (filename/append "machines/C" + "lapgen" + "rules1" "rules2" "rules3" "rules4" + "rulfix" "rulflo" "cout" + ) + (map (lambda (entry) + `(,(car entry) + (PACKAGE/REFERENCE (FIND-PACKAGE '(COMPILER LAP-SYNTAXER)) + ',(cadr entry)))) + '((LAP:SYNTAX-INSTRUCTION LAP:SYNTAX-INSTRUCTION-EXPANDER) + (INSTRUCTION->INSTRUCTION-SEQUENCE + INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER) + (SYNTAX-EVALUATION SYNTAX-EVALUATION-EXPANDER) + (CONS-SYNTAX CONS-SYNTAX-EXPANDER) + (OPTIMIZE-GROUP-EARLY OPTIMIZE-GROUP-EXPANDER) + (EA-KEYWORD-EARLY EA-KEYWORD-EXPANDER) + (EA-MODE-EARLY EA-MODE-EXPANDER) + (EA-REGISTER-EARLY EA-REGISTER-EXPANDER) + (EA-EXTENSION-EARLY EA-EXTENSION-EXPANDER) + (EA-CATEGORIES-EARLY EA-CATEGORIES-EXPANDER)))))) + +(define-integrable (make-expansion-declaration expansions) + `(EXPAND-OPERATOR ,@expansions)) + +(define-integrable (expansion-declaration? declaration) + (eq? (car declaration) 'EXPAND-OPERATOR)) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/lapgen.scm b/v7/src/compiler/machines/C/lapgen.scm new file mode 100644 index 000000000..e4a3b3420 --- /dev/null +++ b/v7/src/compiler/machines/C/lapgen.scm @@ -0,0 +1,575 @@ +#| -*-Scheme-*- + +$Id: lapgen.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Rules for C. Shared utilities. +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Compiler error reporting + +(define (comp-internal-error message location . irritants) + (apply error (cons (string-append "Internal inconsistency in " + (if (symbol? location) + (symbol->string location) + location) + ": " + message) + irritants))) + +;;;; Register-Allocator Interface + +(define (type->name type) + (case type + ((SCHEME_OBJECT) + "SCHEME_OBJECT") + ((SCHEME_OBJECT*) + "SCHEME_OBJECT *") + ((LONG) + "long") + ((CHAR*) + "char *") + ((ULONG) + "unsigned long") + ((DOUBLE) + "double") + (else + (comp-internal-error "Unknown type" 'TYPE->NAME type)))) + +(define (reg*type->name reg type) + (case type + ((SCHEME_OBJECT) + (string-append "Obj" (number->string reg))) + ((SCHEME_OBJECT*) + (string-append "pObj" (number->string reg))) + ((LONG) + (string-append "Lng" (number->string reg))) + ((CHAR*) + (string-append "pChr" (number->string reg))) + ((ULONG) + (string-append "uLng" (number->string reg))) + ((DOUBLE) + (string-append "Dbl" (number->string reg))) + (else + (comp-internal-error "Unknown type" 'REG*TYPE->NAME type)))) + +(define (machine-register-name reg) + (cond ((eq? reg regnum:stack-pointer) + "stack_pointer") + ((eq? reg regnum:free) + "free_pointer") + ((eq? reg regnum:regs) + "register_block") + ((eq? reg regnum:dynamic-link) + "dynamic_link") + ((eq? reg regnum:value) + "value_reg") + (else + (comp-internal-error "Unknown machine register" + 'MACHINE-REGISTER-NAME reg)))) + +(define (machine-register-type reg) + (cond ((eq? reg regnum:value) + "SCHEME_OBJECT") + #| + ((eq? reg regnum:stack-pointer) + "SCHEME_OBJECT *") + ((eq? reg regnum:free) + "SCHEME_OBJECT *") + ((eq? reg regnum:regs) + "SCHEME_OBJECT *") + ((eq? reg regnum:dynamic-link) + "SCHEME_OBJECT *") + (else + (comp-internal-error "Unknown machine register" + 'MACHINE-REGISTER-TYPE reg)) + |# + (else + "SCHEME_OBJECT *"))) + +(define (machine-register-type-symbol reg) + (cond ((eq? reg regnum:value) + 'SCHEME_OBJECT) + #| + ((eq? reg regnum:stack-pointer) + 'SCHEME_OBJECT*) + ((eq? reg regnum:free) + 'SCHEME_OBJECT*) + ((eq? reg regnum:regs) + 'SCHEME_OBJECT*) + ((eq? reg regnum:dynamic-link) + 'SCHEME_OBJECT*) + (else + (comp-internal-error "Unknown machine register" + 'MACHINE-REGISTER-TYPE-SYMBOL reg)) + |# + (else + 'SCHEME_OBJECT*))) + +(define-integrable (register-is-machine-register? reg) + (< reg number-of-machine-registers)) + +(define (cast reg type) + (string-append "((" (type->name type) ") " reg ")")) + +(define permanent-register-list) +(define current-register-list) + +(define (find-register reg type) + (let ((aliases (assq reg current-register-list))) + (and aliases + (let ((alias (assq type (cdr aliases)))) + (cond (alias (cdr alias)) + ((not type) + (cdadr aliases)) + (else false)))))) + +(define (standard-source! reg type) + (cond ((register-is-machine-register? reg) + (let ((name (machine-register-name reg))) + (if (eq? (machine-register-type-symbol reg) type) + name + (cast name type)))) + ((find-register reg type)) + ((find-register reg false) + => (lambda (reg) + (cast reg type))) + (else + (comp-internal-error "Unallocated register" + 'STANDARD-SOURCE! reg)))) + +(define (standard-target! reg type) + (cond ((register-is-machine-register? reg) + (machine-register-name reg)) + ((assq reg current-register-list) + => (lambda (aliases) + (let ((alias (assq type (cdr aliases)))) + (if (or (not alias) + (not (null? (cddr aliases)))) + (let ((name (new-register-name reg type))) + (set-cdr! aliases (list (cons type name))) + name) + (cdr alias))))) + (else + (let ((name (new-register-name reg type))) + (set! current-register-list + (cons (list reg (cons type name)) + current-register-list)) + name)))) + +(define (new-register-name reg type) + (cond ((assq reg permanent-register-list) + => (lambda (aliases) + (let ((alias (assq type (cdr aliases)))) + (if alias + (cdr alias) + (let ((name (reg*type->name reg type))) + (set-cdr! aliases + (cons (cons type name) (cdr aliases))) + name))))) + (else + (let ((name (reg*type->name reg type))) + (set! permanent-register-list + (cons (list reg (cons type name)) + permanent-register-list)) + name)))) + +(define (register-declarations) + (append-map + (lambda (register) + (map (lambda (spec) + (string-append (type->name (car spec)) " " (cdr spec) ";\n\t")) + (cdr register))) + permanent-register-list)) + +(define (standard-move-to-target! src tgt) + ;; This is bogus but we have no more information + + (define (do-tgt src src-type) + (let ((tgt (standard-target! tgt src-type))) + (LAP ,tgt " = " ,src ";\n\t"))) + + (cond ((register-is-machine-register? src) + (do-tgt (machine-register-name src) + (machine-register-type-symbol src))) + ((assq src current-register-list) + => (lambda (aliases) + (let ((alias (cadr aliases))) + (do-tgt (cdr alias) (car alias))))) + (else + (comp-internal-error "Unallocated register" + 'STANDARD-MOVE-TO-TARGET! src)))) + +;;;; Communicate with cout.scm + +(define (use-invoke-interface! number) + (set! *invoke-interface* + (let ((old *invoke-interface*)) + (if (eq? old 'infinity) + number + (min old number))))) + +(define (use-invoke-primitive!) + (set! *used-invoke-primitive* true)) + +(define (use-closure-interrupt-check!) + (use-invoke-interface! 0)) + +(define (use-interrupt-check!) + (use-invoke-interface! 1)) + +(define (use-dlink-interrupt-check!) + (use-invoke-interface! 2)) + +(define (use-jump-execute-chache!) + (set! *use-jump-execute-chache* #t)) + +(define (use-pop-return!) + (set! *use-pop-return* #t)) + +;;;; Constants, Labels, and Various Caches + +(define-integrable make-entry cons) +(define-integrable entry-value car) +(define-integrable entry-label cdr) + +(define-integrable (make-table) + (cons 0 '())) + +(define-integrable table->list-of-entries cdr) + +(define (find-association table value) + (let ((x (assoc value (cdr table)))) + (if x + (entry-label x) + #f))) + +(define (add-object! table name value) + (set-cdr! table + (cons (make-entry value name) + (cdr table))) + unspecific) + +(define (add-association! table value prefix) + (let ((num (car table))) + (add-object! table + (string-append prefix + *disambiguator* + (number->string num)) + value) + (set-car! table (1+ num)) + num)) + +(define (find-or-add table value prefix) + (let ((x (find-association table value))) + (if x + x + (begin + (add-association! table value prefix) + (find-association table value))))) + +(define (define-object name value) + (add-object! objects + (if (symbol? name) + (symbol->string name) + name) + value)) + +(define (object-label-value label) + (let ((entry + (list-search-positive (table->list-of-entries objects) + (lambda (entry) + (string=? label (entry-label entry)))))) + (if (not entry) + (error "object-label-value: Unknown" label) + (entry-value entry)))) + +(define objects) +(define free-references) +(define free-assignments) +(define free-uuo-links) +(define global-uuo-links) + +(define labels) +(define label-num) + +(define (make-special-labels) + (define (frob name) + (string->uninterned-symbol (generate-new-label-symbol name))) + + (vector (frob "ENVIRONMENT_LABEL_") + (frob "FREE_REFERENCES_LABEL_") + (frob "NUMBER_OF_LINKER_SECTIONS_") + (frob "DEBUGGING_LABEL_"))) + +(define-integrable (special-label/environment) + (vector-ref *special-labels* 0)) + +(define-integrable (special-label/free-references) + (vector-ref *special-labels* 1)) + +(define-integrable (special-label/number-of-sections) + (vector-ref *special-labels* 2)) + +(define-integrable (special-label/debugging) + (vector-ref *special-labels* 3)) + +(define (prepare-constants-block) + (values (LAP) + (special-label/environment) + (special-label/free-references) + (special-label/number-of-sections))) + +(define (uuo-link-label table name frame-size prefix) + (define-integrable (uuo-link-label name) + name ; ignored + (generate-new-label-symbol prefix)) + + (let ((slot1 (assq name (cdr table)))) + (if (not slot1) + (let ((label (uuo-link-label name))) + (set-cdr! table + (cons (list name (cons frame-size label)) + (cdr table))) + label) + (let ((slot2 (assq frame-size (cdr slot1)))) + (if (not slot2) + (let ((label (uuo-link-label name))) + (set-cdr! slot1 + (cons (cons frame-size label) + (cdr slot1))) + label) + (cdr slot2)))))) + +(define (free-uuo-link-label name frame-size) + (uuo-link-label free-uuo-links name frame-size "EXECUTE_CACHE_")) + +(define (global-uuo-link-label name frame-size) + (uuo-link-label global-uuo-links name frame-size "GLOBAL_EXECUTE_CACHE_")) + +;; this alias is for lapgn1.scm + +(define (constant->label object) + (declare (integrate object->offset)) + (object->offset object)) + +(define (object->offset scheme-object) + (find-or-add objects scheme-object "OBJECT_")) + +(define (free-reference->offset name) + (find-or-add free-references name "FREE_REFERENCE_")) + +(define (free-assignment->offset name) + (find-or-add free-assignments name "FREE_ASSIGNMENT_")) + +(define-integrable label-1 vector-first) +(define-integrable label-2 vector-second) +(define-integrable symbol-1 vector-third) +(define-integrable symbol-2 vector-fourth) +(define-integrable dispatch-1 vector-fifth) +(define-integrable (set-dispatch-1! x d) + (vector-set! x 4 d)) +(define-integrable dispatch-2 vector-sixth) +(define-integrable code-word-sel vector-seventh) + +(define (find-label label labels) + (let loop ((labels labels)) + (and (not (null? labels)) + (let ((next (car labels))) + (if (or (eq? label (label-1 next)) + (eq? label (label-2 next))) + next + (loop (cdr labels))))))) + +(define (generate-new-label-symbol prefix) + (let ((num label-num)) + (set! label-num (1+ num)) + (string-append prefix + *disambiguator* + (number->string num)))) + +(define (define-label! label) + (set! labels + (cons (vector label #f + (generate-new-label-symbol "LABEL_") + #f #f #f #f) + labels)) + unspecific) + +(define (label->offset label) + (let ((x (find-label label labels))) + (if x + (symbol-1 x) + (begin + (define-label! label) + (label->offset label))))) + +(define (label->dispatch-tag label) + (let ((x (find-label label labels))) + (if x + (or (dispatch-1 x) + (let ((sym (generate-new-label-symbol "TAG_"))) + (set-dispatch-1! x sym) + sym)) + (begin + (define-label! label) + (label->dispatch-tag label))))) + +(define (declare-block-label! code-word label external-label) + (define (add-new-entry symbol-x symbol-y dispatch-x dispatch-y) + (set! labels + (cons (vector label external-label + symbol-x symbol-y + dispatch-x dispatch-y + code-word) + labels))) + + (let ((x (and label (find-label label labels))) + (y (and external-label (find-label external-label labels)))) + (if x + (set! labels (delq! x labels))) + (if y + (set! labels (delq! y labels))) + (cond ((and x (eq? x y)) + (add-new-entry (symbol-1 x) (symbol-2 x) + (dispatch-1 x) (dispatch-2 x))) + ((and x y) + (add-new-entry (symbol-1 x) (symbol-1 y) + (dispatch-1 x) (dispatch-1 y))) + (x + (add-new-entry (symbol-1 x) #f + (dispatch-1 x) #f)) + (y + (add-new-entry (symbol-1 y) #f + (dispatch-1 y) #f)) + (else + (add-new-entry (generate-new-label-symbol "LABEL_") + #f + #f + #f))) + unspecific)) + +(define available-machine-registers + ;; This is really a lie, but lets some things work + (list + regnum:stack-pointer regnum:regs regnum:free + regnum:dynamic-link regnum:value)) + +(define (sort-machine-registers lst) + lst) + +(define (register-type reg) + (comp-internal-error "Should not be using register allocator" + 'REGISTER-TYPE reg)) + +(define (register-types-compatible? x y) + (comp-internal-error "Should not be using register allocator" + 'REGISTER-TYPES-COMPATIBLE? x y)) + +(define (register-reference num) + (comp-internal-error "Should not be using register allocator" + 'REGISTER-REFERENCE num)) + +(define (register->register-transfer one two) + (comp-internal-error "Should not be using register allocator" + 'REGISTER->REGISTER-TRANSFER one two)) + +(define (reference->register-transfer one two) + (comp-internal-error "Should not be using register allocator" + 'REFERENCE->REGISTER-TRANSFER one two)) + +(define (pseudo-register-home one) + (comp-internal-error "Should not be using register allocator" + 'PSEUDO-REGISTER-HOME one)) + +(define (home->register-transfer one two) + (comp-internal-error "Should not be using register allocator" + 'HOME->REGISTER-TRANSFER one two)) + +(define (register->home-transfer one two) + (comp-internal-error "Should not be using register allocator" + 'REGISTER->HOME-TRANSFER one two)) + +(define (lap:make-label-statement label) + (LAP "\n" ,label ":\n\t" )) + +(define (lap:make-unconditional-branch label) + (LAP "goto " ,label ";\n\t")) + +(define (lap:make-entry-point label block-start-label) + block-start-label ; ignored + (declare-block-label! expression-code-word label #f) + (lap:make-label-statement label)) + +(define (compare cc val1 val2) + (set-current-branches! + (lambda (label) + (LAP "if (" ,val1 ,cc ,val2 ")\n\t goto " ,label ";\n\t")) + (lambda (label) + (LAP "if (!(" ,val1 ,cc ,val2 "))\n\t goto " ,label ";\n\t"))) + (LAP)) + +(define (define-arithmetic-method operator methods method) + (let ((entry (assq operator (cdr methods)))) + (if entry + (set-cdr! entry method) + (set-cdr! methods (cons (cons operator method) (cdr methods))))) + operator) + +(define (lookup-arithmetic-method operator methods) + (cdr (or (assq operator (cdr methods)) + (comp-internal-error "Unknown operator" 'LOOKUP-ARITHMETIC-METHOD + operator)))) + +(let-syntax ((define-codes + (macro (start . names) + (define (loop names index) + (if (null? names) + '() + (cons `(DEFINE-INTEGRABLE + ,(symbol-append 'CODE:COMPILER- + (car names)) + ,index) + (loop (cdr names) (1+ index))))) + `(BEGIN ,@(loop names start))))) + (define-codes #x012 + primitive-apply primitive-lexpr-apply + apply error lexpr-apply link + interrupt-closure interrupt-dlink interrupt-procedure + interrupt-continuation interrupt-ic-procedure + assignment-trap cache-reference-apply + reference-trap safe-reference-trap unassigned?-trap + -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero? + access lookup safe-lookup unassigned? unbound? + set! define lookup-apply)) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/machin.scm b/v7/src/compiler/machines/C/machin.scm new file mode 100644 index 000000000..fceb50a2d --- /dev/null +++ b/v7/src/compiler/machines/C/machin.scm @@ -0,0 +1,310 @@ +#| -*-Scheme-*- + +$Id: machin.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Machine Model for C +;;; package: (compiler) + +(declare (usual-integrations)) + +;;;; Architecture Parameters + +(define use-pre/post-increment? true) +(define endianness 'DONT-KNOW) +(define scheme-object-width "OBJECT_LENGTH") +(define scheme-type-width "TYPE_CODE_LENGTH") + +(define scheme-datum-width "DATUM_LENGTH") + +;;; It is currently required that both packed characters and objects +;;; be integrable numbers of address units. Furthermore, the number +;;; of address units per object must be an integral multiple of the +;;; number of address units per character. This will cause problems +;;; on a machine that is word addressed, in which case we will have to +;;; rethink the character addressing strategy. + +(define address-units-per-object "ADDRESS_UNITS_PER_OBJECT") + +(define-integrable address-units-per-packed-char 1) + +;; We expect a C long to be at least 32 bits wide, +;; but not necessarily two's complement. + +(define-integrable min-long-width 32) +(define-integrable max-tag-width 8) + +(define-integrable guaranteed-long/upper-limit + (expt 2 min-long-width)) +(define-integrable guaranteed-long/lower-limit + (- (-1+ guaranteed-long/upper-limit))) + +(define signed-fixnum/upper-limit + (expt 2 (- min-long-width (1+ max-tag-width)))) +(define signed-fixnum/lower-limit + (- signed-fixnum/upper-limit)) + +(define-integrable (stack->memory-offset offset) offset) +(define-integrable ic-block-first-parameter-offset 2) +(define-integrable execute-cache-size 2) ; Long words per UUO link slot +(define-integrable closure-entry-size + ;; Long words in a single closure entry: + ;; Format + GC offset word + ;; C procedure descriptor + switch tag + ;; pointer to code block + 3) + +;; Given: the number of entry points in a closure, and a particular +;; entry point number. Return: the distance from that entry point to +;; the first variable slot in the closure (in words). + +(define (closure-first-offset nentries entry) + (if (zero? nentries) + 1 ; Strange boundary case + (- (* closure-entry-size (- nentries entry)) 1))) + +;; Like the above, but from the start of the complete closure object, +;; viewed as a vector, and including the header word. + +(define (closure-object-first-offset nentries) + (case nentries + ((0) + ;; Vector header only + 1) + ((1) + ;; Manifest closure header followed by single entry point + (+ 1 closure-entry-size)) + (else + ;; Manifest closure header, number of entries, then entries. + (+ 1 1 (* closure-entry-size nentries))))) + +;; Bump from one entry point to another -- distance in BYTES + +(define (closure-entry-distance nentries entry entry*) ; for now + nentries ; ignored + (let ((entry-delta (- entry* entry))) + (if (zero? entry-delta) + 0 + (string-append "((sizeof (SCHEME_OBJECT)) * " + (number->string + (* closure-entry-size entry-delta)) + ")")))) + +;; Bump to the canonical entry point. On a RISC (which forces +;; longword alignment for entry points anyway) there is no need to +;; canonicalize. + +(define (closure-environment-adjustment nentries entry) + nentries entry ; ignored + 0) + +;;;; Machine Registers + +(define-integrable number-of-machine-registers 5) ; for now +(define-integrable number-of-temporary-registers 1000000) ; enough? + +;;; Fixed-use registers for Scheme compiled code. +(define-integrable regnum:regs 0) +(define-integrable regnum:stack-pointer 1) +(define-integrable regnum:free 2) +(define-integrable regnum:dynamic-link 3) +(define-integrable regnum:value 4) + +;;; Fixed-use registers due to architecture or OS calling conventions. + +(define machine-register-value-class + (let ((special-registers + `((,regnum:stack-pointer . ,value-class=address) + (,regnum:regs . ,value-class=unboxed) + (,regnum:free . ,value-class=address) + (,regnum:dynamic-link . ,value-class=address) + (,regnum:value . ,value-class=object)))) + + (lambda (register) + (let ((lookup (assv register special-registers))) + (cond + ((not (null? lookup)) (cdr lookup)) + (else (error "illegal machine register" register))))))) + +(define-integrable (machine-register-known-value register) + register ;ignore + false) + +;;;; Interpreter Registers + +(define-integrable register-block/memtop-offset 0) +(define-integrable register-block/value-offset 2) +(define-integrable register-block/environment-offset 3) +(define-integrable register-block/dynamic-link-offset 4) ; compiler temp +(define-integrable register-block/lexpr-primitive-arity-offset 7) +(define-integrable register-block/utility-arg4-offset 9) ; closure free +(define-integrable register-block/stack-guard-offset 11) + +(define-integrable (interpreter-free-pointer) + (rtl:make-machine-register regnum:free)) + +(define (interpreter-free-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:free))) + +(define-integrable (interpreter-regs-pointer) + (rtl:make-machine-register regnum:regs)) + +(define (interpreter-regs-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:regs))) + +(define-integrable (interpreter-value-register) + #| + (rtl:make-offset (interpreter-regs-pointer) + register-block/value-offset) + |# + (rtl:make-machine-register regnum:value)) + +(define (interpreter-value-register? expression) + #| + (and (rtl:offset? expression) + (interpreter-regs-pointer? (rtl:offset-base expression)) + (= (rtl:offset-number expression) register-block/value-offset)) + |# + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:value))) + +(define-integrable (interpreter-stack-pointer) + (rtl:make-machine-register regnum:stack-pointer)) + +(define (interpreter-stack-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:stack-pointer))) + +(define-integrable (interpreter-dynamic-link) + (rtl:make-machine-register regnum:dynamic-link)) + +(define (interpreter-dynamic-link? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:dynamic-link))) + +(define-integrable (interpreter-environment-register) + (rtl:make-offset (interpreter-regs-pointer) + register-block/environment-offset)) + +(define (interpreter-environment-register? expression) + (and (rtl:offset? expression) + (interpreter-regs-pointer? (rtl:offset-base expression)) + (= register-block/environment-offset (rtl:offset-number expression)))) + +(define-integrable (interpreter-register:access) + (interpreter-value-register)) + +(define-integrable (interpreter-register:cache-reference) + (interpreter-value-register)) + +(define-integrable (interpreter-register:cache-unassigned?) + (interpreter-value-register)) + +(define-integrable (interpreter-register:lookup) + (interpreter-value-register)) + +(define-integrable (interpreter-register:unassigned?) + (interpreter-value-register)) + +(define-integrable (interpreter-register:unbound?) + (interpreter-value-register)) + +;;;; RTL Registers, Constants, and Primitives + +(define (rtl:machine-register? rtl-register) + (case rtl-register + ((STACK-POINTER) + (interpreter-stack-pointer)) + ((DYNAMIC-LINK) + (interpreter-dynamic-link)) + ((VALUE) + (interpreter-value-register)) + ((INTERPRETER-CALL-RESULT:ACCESS) + (interpreter-register:access)) + ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) + (interpreter-register:cache-reference)) + ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) + (interpreter-register:cache-unassigned?)) + ((INTERPRETER-CALL-RESULT:LOOKUP) + (interpreter-register:lookup)) + ((INTERPRETER-CALL-RESULT:UNASSIGNED?) + (interpreter-register:unassigned?)) + ((INTERPRETER-CALL-RESULT:UNBOUND?) + (interpreter-register:unbound?)) + (else + false))) + +(define (rtl:interpreter-register? rtl-register) + (case rtl-register + ((MEMORY-TOP) + register-block/memtop-offset) + ((STACK-GUARD) + register-block/stack-guard-offset) + ((ENVIRONMENT) + register-block/environment-offset) + #| + ((VALUE) + register-block/value-offset) + ((INTERPRETER-CALL-RESULT:ACCESS) + register-block/value-offset) + ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) + register-block/value-offset) + ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) + register-block/value-offset) + ((INTERPRETER-CALL-RESULT:LOOKUP) + register-block/value-offset) + ((INTERPRETER-CALL-RESULT:UNASSIGNED?) + register-block/value-offset) + ((INTERPRETER-CALL-RESULT:UNBOUND?) + register-block/value-offset) + |# + (else + false))) + +(define (rtl:interpreter-register->offset locative) + (or (rtl:interpreter-register? locative) + (error "Unknown register type" locative))) + +(define (rtl:constant-cost expression) + expression ; ignored + 1) + +(define compiler:open-code-floating-point-arithmetic? + true) + +(define compiler:primitives-with-no-open-coding + '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS + FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND + FLONUM-REMAINDER FLONUM-SQRT)) + diff --git a/v7/src/compiler/machines/C/make.scm b/v7/src/compiler/machines/C/make.scm new file mode 100644 index 000000000..d01edc037 --- /dev/null +++ b/v7/src/compiler/machines/C/make.scm @@ -0,0 +1,42 @@ +#| -*-Scheme-*- + +$Id: make.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler: System Construction + +(declare (usual-integrations)) + +(let ((value ((load "base/make") "C"))) + (set! (access compiler:compress-top-level? (->environment '(compiler))) + true) + value) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/rgspcm.scm b/v7/src/compiler/machines/C/rgspcm.scm new file mode 100644 index 000000000..880df131f --- /dev/null +++ b/v7/src/compiler/machines/C/rgspcm.scm @@ -0,0 +1,74 @@ +#| -*-Scheme-*- + +$Id: rgspcm.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Generation: Special primitive combinations. + +(declare (usual-integrations)) + +(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/C/rules1.scm b/v7/src/compiler/machines/C/rules1.scm new file mode 100644 index 000000000..3b8d1d451 --- /dev/null +++ b/v7/src/compiler/machines/C/rules1.scm @@ -0,0 +1,328 @@ +#| -*-Scheme-*- + +$Id: rules1.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Data Transfers +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Simple Operations + +;;; All assignments to pseudo registers are required to delete the +;;; dead registers BEFORE performing the assignment. However, it is +;;; necessary to derive the effective address of the source +;;; expression(s) before deleting the dead registers. Otherwise any +;;; source expression containing dead registers might refer to aliases +;;; which have been reused. + +(define-rule statement + (ASSIGN (REGISTER (? target)) (REGISTER (? source))) + (standard-move-to-target! source target)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum)))) + (let* ((datum (standard-source! datum 'SCHEME_OBJECT*)) + (type (standard-source! type 'ULONG)) + (target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", " ,datum "));\n\t"))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (REGISTER (? type)) (REGISTER (? datum)))) + (let* ((datum (standard-source! datum 'SCHEME_OBJECT*)) + (type (standard-source! type 'ULONG)) + (target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = (MAKE_OBJECT (" ,type ", " ,datum "));\n\t"))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source)))) + (let* ((datum (standard-source! source 'SCHEME_OBJECT*)) + (target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", " ,datum "));\n\t"))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source)))) + (let* ((datum (standard-source! source 'LONG)) + (target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = (MAKE_OBJECT (" ,type ", " ,datum "));\n\t"))) + +(define (standard-unary-conversion source source-type target target-type + conversion) + (let* ((source (standard-source! source source-type)) + (target (standard-target! target target-type))) + (conversion source target))) + +(define (standard-binary-conversion source1 source1-type source2 source2-type + target target-type conversion) + (let* ((source1 (standard-source! source1 source1-type)) + (source2 (standard-source! source2 source2-type)) + (target (standard-target! target target-type))) + (conversion source1 source2 target))) + +(define (object->type source target) + (LAP ,target " = (OBJECT_TYPE (" ,source "));\n\t")) + +(define (object->datum source target) + (LAP ,target " = (OBJECT_DATUM (" ,source "));\n\t")) + +(define (object->address source target) + (LAP ,target " = (OBJECT_ADDRESS (" ,source "));\n\t")) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) + (standard-unary-conversion source 'SCHEME_OBJECT target 'ULONG + object->type)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) + (standard-unary-conversion source 'SCHEME_OBJECT target 'ULONG + object->datum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) + (standard-unary-conversion source 'SCHEME_OBJECT target 'SCHEME_OBJECT* + object->address)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OFFSET-ADDRESS (REGISTER (? source)) (? offset))) + (standard-unary-conversion + source 'SCHEME_OBJECT* target 'SCHEME_OBJECT* + (lambda (source target) + (LAP ,target " = &" ,source "[" ,offset "];\n\t")))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? offset))) + (standard-unary-conversion + source 'CHAR* target 'CHAR* + (lambda (source target) + (LAP ,target " = &" ,source "[" ,offset "];\n\t")))) + +;;;; Loading of Constants + +(define-rule statement + ;; load a machine constant + (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source))) + (let ((target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = ((SCHEME_OBJECT) " ,source ");\n\t"))) + +(define-rule statement + ;; load a Scheme constant + (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) + (let ((target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = current_block[" ,(object->offset source) "];\n\t"))) + +(define-rule statement + ;; load the type part of a Scheme constant + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant)))) + (let ((target (standard-target! target 'ULONG))) + (LAP ,target " = (OBJECT_TYPE (current_block[" + ,(object->offset constant) "]));\n\t"))) + +(define-rule statement + ;; load the datum part of a Scheme constant + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) + (QUALIFIER (non-pointer-object? constant)) + (let ((target (standard-target! target 'ULONG))) + (LAP ,target " = (OBJECT_DATUM (current_block[" + ,(object->offset constant) "]));\n\t"))) + +(define-rule statement + ;; load a synthesized constant + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (let((target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = (MAKE_OBJECT (" ,type ", " ,datum "));\n\t"))) + +(define-rule statement + ;; load the address of a variable reference cache + (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) + (let ((target (standard-target! target 'SCHEME_OBJECT*))) + (LAP ,target " = ((SCHEME_OBJECT *) current_block[" + ,(free-reference->offset name) "]);\n\t"))) + +(define-rule statement + ;; load the address of an assignment cache + (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) + (let ((target (standard-target! target 'SCHEME_OBJECT*))) + (LAP ,target " = ((SCHEME_OBJECT *) current_block[" + ,(free-assignment->offset name) "]);\n\t"))) + +(define-rule statement + ;; load the address of a procedure's entry point + (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) + (let ((target (standard-target! target 'SCHEME_OBJECT*))) + (LAP ,target " = ¤t_block[" ,(label->offset label) "];\n\t"))) + +(define-rule statement + ;; load the address of a continuation + (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) + (let ((target (standard-target! target 'SCHEME_OBJECT*))) + (LAP ,target " = ¤t_block[" ,(label->offset label) "];\n\t"))) + +(define-rule statement + ;; load a procedure object + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (let ((target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", ¤t_block[" + ,(label->offset label) "]));\n\t"))) + +(define-rule statement + ;; load a return address object + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:CONTINUATION (? label)))) + (let ((target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", ¤t_block[" + ,(label->offset label) "]));\n\t"))) + +;;;; Transfers from memory + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) + (standard-unary-conversion address 'SCHEME_OBJECT* target 'SCHEME_OBJECT + (lambda (address target) + (LAP ,target " = " ,address "[" ,offset "];\n\t")))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? rsp)) 1)) + (QUALIFIER (= rsp regnum:stack-pointer)) + (let ((target (standard-target! target 'SCHEME_OBJECT))) + (LAP ,target " = *stack_pointer++;\n\t"))) + +;;;; Transfers to memory + +(define-rule statement + ;; store an object in memory + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) + (REGISTER (? source))) + (let* ((source (standard-source! source 'SCHEME_OBJECT)) + (address (standard-source! address 'SCHEME_OBJECT*))) + (LAP ,address "[" ,offset "] = " ,source ";\n\t"))) + +(define-rule statement + ;; Push an object register on the heap + (ASSIGN (POST-INCREMENT (REGISTER (? rfree)) 1) + (REGISTER (? source))) + (QUALIFIER (= rfree regnum:free)) + (let ((source (standard-source! source 'SCHEME_OBJECT))) + (LAP "*free_pointer++ = " ,source ";\n\t"))) + +(define-rule statement + ;; Push an object register on the stack + (ASSIGN (PRE-INCREMENT (REGISTER (? rsp)) -1) + (REGISTER (? source))) + (QUALIFIER (= rsp regnum:stack-pointer)) + (let ((source (standard-source! source 'SCHEME_OBJECT))) + (LAP "*--stack_pointer = " ,source ";\n\t"))) + +;; Cheaper, common patterns. + +(define-rule statement + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) + (MACHINE-CONSTANT 0)) + (let ((address (standard-source! address 'SCHEME_OBJECT*))) + (LAP ,address "[" ,offset "] = ((SCHEME_OBJECT) 0);\n\t"))) + +(define-rule statement + ; Push NIL (or whatever is represented by a machine 0) on heap + (ASSIGN (POST-INCREMENT (REGISTER (? rfree)) 1) (MACHINE-CONSTANT 0)) + (QUALIFIER (= rfree regnum:free)) + (LAP "*free_pointer++ = ((SCHEME_OBJECT) 0);\n\t")) + +(define-rule statement + ;; Push an object register on the stack + (ASSIGN (PRE-INCREMENT (REGISTER (? rsp)) -1) + (MACHINE-CONSTANT (? const))) + (QUALIFIER (= rsp regnum:stack-pointer)) + (LAP "*--stack_pointer = ((SCHEME_OBJECT) " ,const ");\n\t")) + +;;;; CHAR->ASCII/BYTE-OFFSET + +(define-rule statement + ;; load char object from memory and convert to ASCII byte + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset)))) + (standard-unary-conversion address 'SCHEME_OBJECT* target 'ULONG + (lambda (address target) + (LAP ,target " = (CHAR_TO_ASCII (" ,address "[" ,offset "]));\n\t")))) + +(define-rule statement + ;; load ASCII byte from memory + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET (REGISTER (? address)) (? offset))) + (standard-unary-conversion address 'CHAR* target 'ULONG + (lambda (address target) + (LAP ,target " = ((ulong) (((unsigned char *) " ,address ")[" + ,offset "]));\n\t")))) + +(define-rule statement + ;; convert char object to ASCII byte + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (REGISTER (? source)))) + (standard-unary-conversion source 'SCHEME_OBJECT target 'ULONG + (lambda (source target) + (LAP ,target " = (CHAR_TO_ASCII (" ,source "));\n\t")))) + +(define-rule statement + ;; store null byte in memory + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (CHAR->ASCII (CONSTANT #\N\TUL))) + (let ((address (standard-source! address 'CHAR*))) + (LAP ,address "[" ,offset "] = '\\0';\n\t"))) + +(define-rule statement + ;; store ASCII byte in memory + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (REGISTER (? source))) + (let ((address (standard-source! address 'CHAR*)) + (source (standard-source! source 'ULONG))) + (LAP ,address "[" ,offset "] = ((char) " ,source ");\n\t"))) + +(define-rule statement + ;; convert char object to ASCII byte and store it in memory + ;; register + byte offset <- contents of register (clear top bits) + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (CHAR->ASCII (REGISTER (? source)))) + (let ((address (standard-source! address 'CHAR*)) + (source (standard-source! source 'SCHEME_OBJECT))) + (LAP ,address "[" ,offset "] = ((char) (CHAR_TO_ASCII (" ,source + ")));\n\t"))) diff --git a/v7/src/compiler/machines/C/rules2.scm b/v7/src/compiler/machines/C/rules2.scm new file mode 100644 index 000000000..aeb18f0e3 --- /dev/null +++ b/v7/src/compiler/machines/C/rules2.scm @@ -0,0 +1,132 @@ +#| -*-Scheme-*- + +$Id: rules2.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Predicates +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +(define-rule predicate + ;; test for two registers EQ? + (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2))) + (let ((source1 (standard-source! source1 'SCHEME_OBJECT)) + (source2 (standard-source! source2 'SCHEME_OBJECT))) + (set-current-branches! + (lambda (if-true-label) + (LAP "if (" ,source1 " == " ,source2 ")\n\t goto " + ,if-true-label ";\n\t")) + (lambda (if-false-label) + (LAP "if (" ,source1 " != " ,source2 ")\n\t goto " + ,if-false-label ";\n\t"))) + (LAP))) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (CONSTANT (? constant)) (REGISTER (? source))) + (eq-test/constant constant source)) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (REGISTER (? source)) (CONSTANT (? constant))) + (eq-test/constant constant source)) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (MACHINE-CONSTANT (? constant)) (REGISTER (? source))) + (eq-test/machine-constant constant source)) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (REGISTER (? source)) (MACHINE-CONSTANT (? constant))) + (eq-test/machine-constant constant source)) + +(define-rule predicate + ;; test for register EQ? to synthesized constant + (EQ-TEST (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum))) + (REGISTER (? source))) + (eq-test/non-pointer type datum source)) + +(define-rule predicate + ;; test for register EQ? to synthesized constant + (EQ-TEST (REGISTER (? source)) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (eq-test/non-pointer type datum source)) + +(define-rule predicate + ;; Branch if virtual register contains the specified type number + (TYPE-TEST (REGISTER (? source)) (? type)) + (let ((source (standard-source! source 'ULONG))) + (set-current-branches! + (lambda (if-true-label) + (LAP "if (" ,source " == " ,type ")\n\t goto " ,if-true-label + ";\n\t")) + (lambda (if-false-label) + (LAP "if (" ,source " != " ,type ")\n\t goto " ,if-false-label + ";\n\t"))) + (LAP))) + +(define (eq-test/constant constant source) + (let ((source (standard-source! source 'SCHEME_OBJECT))) + (set-current-branches! + (lambda (if-true-label) + (LAP "if (" ,source " == current_block[" ,(object->offset constant) + "])\n\t goto " ,if-true-label ";\n\t")) + (lambda (if-false-label) + (LAP "if (" ,source " != current_block[" ,(object->offset constant) + "])\n\t goto " ,if-false-label ";\n\t"))) + (LAP))) + +(define (eq-test/machine-constant constant source) + (let ((source (standard-source! source 'SCHEME_OBJECT))) + (set-current-branches! + (lambda (if-true-label) + (LAP "if (" ,source " == ((SCHEME_OBJECT) " ,constant "))\n\t goto " + ,if-true-label ";\n\t")) + (lambda (if-false-label) + (LAP "if (" ,source " != ((SCHEME_OBJECT) " ,constant "))\n\t goto " + ,if-false-label ";\n\t"))) + (LAP))) + +(define (eq-test/non-pointer type datum source) + (let ((source (standard-source! source 'SCHEME_OBJECT))) + (set-current-branches! + (lambda (if-true-label) + (LAP "if (" ,source " == (MAKE_OBJECT (" ,type ", " ,datum + ")))\n\t goto " ,if-true-label ";\n\t")) + (lambda (if-false-label) + (LAP "if (" ,source " != (MAKE_OBJECT (" ,type ", " ,datum + ")))\n\t goto " ,if-false-label ";\n\t"))) + (LAP))) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/rules3.scm b/v7/src/compiler/machines/C/rules3.scm new file mode 100644 index 000000000..471ea57c6 --- /dev/null +++ b/v7/src/compiler/machines/C/rules3.scm @@ -0,0 +1,669 @@ +#| -*-Scheme-*- + +$Id: rules3.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Invocations and Entries +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Invocations + +(define (pop-return) + (use-pop-return!) + (LAP ,@(clear-map!) + "POP_RETURN();\n\t")) + +(define-rule statement + (POP-RETURN) + (pop-return)) + +(define-rule statement + (INVOCATION:APPLY (? frame-size) (? continuation)) + continuation ;ignore + (let () + (use-invoke-interface! 2) + (LAP ,@(clear-map!) + "{\n\t SCHEME_OBJECT procedure = *stack_pointer++;\n\t" + " INVOKE_INTERFACE_2 (" ,code:compiler-apply ", procedure, " + ,frame-size ");\n\t}\n\t"))) + +(define-rule statement + (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) + frame-size continuation ;ignore + (LAP ,@(clear-map!) + "goto " ,label ";\n\t")) + +(define-rule statement + (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation)) + frame-size continuation ;ignore + (pop-return)) + +(define-rule statement + (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) + continuation ;ignore + (let () + (use-invoke-interface! 2) + (LAP ,@(clear-map!) + "{\n\t SCHEME_OBJECT * procedure_address = ¤t_block[" + ,(label->offset label) + "];\n\t INVOKE_INTERFACE_2 (" ,code:compiler-lexpr-apply + ", procedure_address, " ,number-pushed ");\n\t}\n\t"))) + +(define-rule statement + (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation)) + continuation ;ignore + ;; Destination address is at TOS; pop it into second-arg + (let () + (use-invoke-interface! 2) + (LAP ,@(clear-map!) + "{n\t SCHEME_OBJECT procedure = *stack_pointer++;\n\t " + "SCHEME_OBJECT * procedure_address = (OBJECT_ADDRESS (procedure));\n\t" + " INVOKE_INTERFACE_2 (" ,code:compiler-lexpr-apply + ", procedure_address, " ,number-pushed ");\n\t}\n\t"))) + +(define-rule statement + (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) + continuation ;ignore + (begin + (use-jump-execute-chache!) + (LAP ,@(clear-map!) + "JUMP_EXECUTE_CHACHE (" ,(free-uuo-link-label name frame-size) ");\n\t"))) + +(define-rule statement + (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name)) + continuation ;ignore + (begin + (use-jump-execute-chache!) + (LAP ,@(clear-map!) + "JUMP_EXECUTE_CHACHE (" ,(global-uuo-link-label name frame-size) ");\n\t"))) + +(define-rule statement + (INVOCATION:CACHE-REFERENCE (? frame-size) + (? continuation) + (REGISTER (? extension))) + continuation ;ignore + (let ((extension (standard-source! extension 'SCHEME_OBJECT*))) + (use-invoke-interface! 3) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_3 (" ,code:compiler-cache-reference-apply + ", " ,extension ", current_block, " ,frame-size ");\n\t"))) + +(define-rule statement + (INVOCATION:LOOKUP (? frame-size) + (? continuation) + (REGISTER (? environment)) + (? name)) + continuation ;ignore + (let ((environment (standard-source! environment 'SCHEME_OBJECT))) + (use-invoke-interface! 3) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_3 (" ,code:compiler-lookup-apply + ", " ,environment ", current_block[" ,(object->offset name) "]" + ", " ,frame-size ");\n\t"))) + +(define-rule statement + (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) + continuation ;ignore + (cond ((eq? primitive compiled-error-procedure) + (use-invoke-interface! 1) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_1 (" ,code:compiler-error ", " + ,frame-size ");\n\t")) + (else + (let ((arity (primitive-procedure-arity primitive))) + (cond ((= arity (-1+ frame-size)) + (use-invoke-primitive!) + (LAP ,@(clear-map!) + "INVOKE_PRIMITIVE (current_block[" + ,(object->offset primitive) "], " + ,arity + ");\n\t")) + #| + ((= arity -1) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_2 (" ,code:compiler-apply + ", (current_block[" ,(object->offset primitive) "]" + ", " ,frame-size ");\n\t")) + |# + (else + (if (not (= arity -1)) + (error "Wrong number of arguments to primitive" + primitive (-1+ frame-size))) + (use-invoke-interface! 2) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_2 (" ,code:compiler-apply + ", current_block[" ,(object->offset primitive) "]" + ", " ,frame-size ");\n\t"))))))) + +(define (invoke-special-primitive code) + (use-invoke-interface! 0) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_0 (" ,code ");\n\t")) + +(let-syntax + ((define-special-primitive-invocation + (macro (name) + `(DEFINE-RULE STATEMENT + (INVOCATION:SPECIAL-PRIMITIVE + (? FRAME-SIZE) + (? CONTINUATION) + ,(make-primitive-procedure name true)) + FRAME-SIZE CONTINUATION + (invoke-special-primitive + ,(symbol-append 'CODE:COMPILER- name)))))) + (define-special-primitive-invocation &+) + (define-special-primitive-invocation &-) + (define-special-primitive-invocation &*) + (define-special-primitive-invocation &/) + (define-special-primitive-invocation &=) + (define-special-primitive-invocation &<) + (define-special-primitive-invocation &>) + (define-special-primitive-invocation 1+) + (define-special-primitive-invocation -1+) + (define-special-primitive-invocation zero?) + (define-special-primitive-invocation positive?) + (define-special-primitive-invocation negative?)) + +;;;; 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 ,regnum:stack-pointer)) + (LAP)) + +(define-rule statement + ;; Move words back to dynamic link marker + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? new-frame))) + (let ((new-frame (standard-source! new-frame 'SCHEME_OBJECT*))) + (move-frame-up frame-size new-frame ""))) + +(define (move-frame-up frame-size new-frame pfx) + (case frame-size + ((0) + (LAP ,pfx "stack_pointer = " ,new-frame ";\n\t")) + ((1) + (LAP ,pfx "*--" ,new-frame " = stack_pointer[0];\n\t" + ,pfx "stack_pointer = " ,new-frame ";\n\t")) + ((2) + (LAP ,pfx "*--" ,new-frame " = stack_pointer[1];\n\t" + ,pfx "*--" ,new-frame " = stack_pointer[0];\n\t" + ,pfx "stack_pointer = " ,new-frame ";\n\t")) + ((3) + (LAP ,pfx "*--" ,new-frame " = stack_pointer[2];\n\t" + ,pfx "*--" ,new-frame " = stack_pointer[1];\n\t" + ,pfx "*--" ,new-frame " = stack_pointer[0];\n\t" + ,pfx "stack_pointer = " ,new-frame ";\n\t")) + (else + (LAP ,pfx "{\n\t SCHEME_OBJECT * frame_top = &stack_pointer[" + ,frame-size "];\n\t" + ,pfx " long frame_size = " ,frame-size ";\n\t" + ,pfx " while ((--frame_size) >= 0)" + ,pfx " *--" ,new-frame " = *--frame_top;\n\t" + ,pfx " stack_pointer = " ,new-frame ";\n\t" + ,pfx "}\n\t")))) + +;;; 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 (? choice-1)) + (REGISTER (? choice-2))) + (let ((choice-1 (standard-source! choice-1 'SCHEME_OBJECT*)) + (choice-2 (standard-source! choice-2 'SCHEME_OBJECT*))) + (LAP "{\n\t SCHEME_OBJECT * new_frame;\n\t" + " new_frame = ((" ,choice-1 " <= " ,choice-2 ") ? " + ,choice-1 " : " ,choice-2 ");\n\t" + ,@(move-frame-up frame-size "new_frame" " ") + "}\n\t"))) + +;;; 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 e-label code) + (declare-block-label! code-word label e-label) + (let ((block-label (label->offset label))) + (use-interrupt-check!) + (LAP ,@(if (not e-label) + (LAP) + (label-statement e-label)) + ,@(label-statement label) + "INTERRUPT_CHECK (" ,code ", (" ,block-label "));\n\t"))) + +(define (dlink-procedure-header code-word label e-label) + (declare-block-label! code-word label e-label) + (let ((block-label (label->offset label))) + (use-dlink-interrupt-check!) + (LAP ,@(if (not e-label) + (LAP) + (label-statement e-label)) + ,@(label-statement label) + "DLINK_INTERRUPT_CHECK (" + ,code:compiler-interrupt-dlink + ", (" ,block-label "));\n\t"))) + +(define-rule statement + (CONTINUATION-ENTRY (? internal-label)) + (declare-block-label! (continuation-code-word internal-label) + internal-label #f) + (label-statement internal-label)) + +(define-rule statement + (CONTINUATION-HEADER (? internal-label)) + (simple-procedure-header (continuation-code-word internal-label) + internal-label + #f + code:compiler-interrupt-continuation)) + +(define-rule statement + (IC-PROCEDURE-HEADER (? internal-label)) + (simple-procedure-header expression-code-word + internal-label + (rtl-procedure/external-label + (label->object internal-label)) + code:compiler-interrupt-ic-procedure)) + +(define-rule statement + (OPEN-PROCEDURE-HEADER (? internal-label)) + (let* ((rtl-proc (label->object internal-label)) + (external-label (rtl-procedure/external-label rtl-proc))) + ((if (rtl-procedure/dynamic-link? rtl-proc) + dlink-procedure-header + (lambda (code-word label external-label) + (simple-procedure-header code-word label external-label + code:compiler-interrupt-procedure))) + (internal-procedure-code-word rtl-proc) + internal-label external-label))) + +(define-rule statement + (PROCEDURE-HEADER (? internal-label) (? min) (? max)) + (simple-procedure-header (make-procedure-code-word min max) + internal-label + (rtl-procedure/external-label + (label->object internal-label)) + code:compiler-interrupt-procedure)) + +;;;; Closures. + +;; Magic for compiled entries. + +(define-integrable (label-statement label) + (lap:make-label-statement label)) + +(define-rule statement + (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) + entry + (if (zero? nentries) + (error "Closure header for closure with no entries!" + internal-label)) + (let ((rtl-proc (label->object internal-label))) + (let ((external-label (rtl-procedure/external-label rtl-proc))) + (declare-block-label! (internal-procedure-code-word rtl-proc) + #f external-label) + (use-closure-interrupt-check!) + (LAP ,@(label-statement external-label) + "CLOSURE_HEADER (" ,(label->offset external-label) ");\n\t" + ,@(label-statement internal-label) + "CLOSURE_INTERRUPT_CHECK (" + ,(number->string code:compiler-interrupt-closure) + ");\n\t")))) + +(define (build-gc-offset-word offset code-word) + (let ((encoded-offset (quotient offset 2))) + (if (eq? endianness 'LITTLE) + (+ (* encoded-offset #x10000) code-word) + (+ (* code-word #x10000) encoded-offset)))) + +(define (write-closure-entry internal-label min max offset) + (let ((external-label + (rtl-procedure/external-label (label->object internal-label)))) + (LAP "WRITE_LABEL_DESCRIPTOR (free_pointer, 0x" + ,(number->string (make-procedure-code-word min max) 16) ", " + ,offset ");\n\t" + "free_pointer[0] = (MAKE_LABEL_WORD (current_C_proc, " + ,(label->dispatch-tag external-label) + "));\n\t" + "free_pointer[1] = ((SCHEME_OBJECT) (¤t_block[" + ,(label->offset external-label) "]));\n\t"))) + +(define (cons-closure target label min max nvars) + (let ((target (standard-target! target 'SCHEME_OBJECT*))) + (LAP "* free_pointer = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", " + ,(+ closure-entry-size nvars) "));\n\t" + "free_pointer += 2;\n\t" + ,target " = free_pointer;\n\t" + ,@(write-closure-entry label min max 2) + "free_pointer += " ,(+ nvars 2) ";\n\t"))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? nvars))) + (cons-closure target procedure-label min max nvars)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-MULTICLOSURE (? nentries) (? nvars) (? entries))) + ;; entries is a vector of all the entry points + (case nentries + ((0) + (let ((dest (standard-target! target 'SCHEME_OBJECT*))) + (LAP ,dest " = free_pointer;\n\t" + "*free_pointer = (MAKE_OBJECT (" ,(ucode-type manifest-vector) + ", " ,nvars "));\n\t" + "free_pointer += " ,(+ nvars 1) ";\n\t"))) + ((1) + (let ((entry (vector-ref entries 0))) + (cons-closure target (car entry) (cadr entry) (caddr entry) nvars))) + (else + (cons-multiclosure target nentries nvars (vector->list entries))))) + +(define (cons-multiclosure target nentries nvars entries) + (let ((target (standard-target! target 'SCHEME_OBJECT*))) + (LAP "* free_pointer = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", " + ,(1+ (+ (* nentries closure-entry-size) nvars)) "));\n\t" + "free_pointer += 2;\n\t" + "WRITE_LABEL_DESCRIPTOR (free_pointer, " ,nentries ", 0);\n\t" + "free_pointer += 1;\n\t" + ,target " = free_pointer;\n\t" + ,@(reduce-right + (lambda (lap1 lap2) + (LAP ,@lap1 ,@lap2)) + (LAP) + (map (lambda (entry offset) + (let ((label (car entry)) + (min (cadr entry)) + (max (caddr entry))) + (LAP ,@(write-closure-entry label min max offset) + "free_pointer += 3;\n\t"))) + entries (make-multiclosure-offsets nentries))) + "free_pointer += " ,(- nvars 1) ";\n\t"))) + +(define (make-multiclosure-offsets nentries) + (let generate ((x nentries) + (offset 3)) + (if (= 0 x) + '() + (cons offset + (generate (-1+ x) + (+ offset closure-entry-size)))))) + +;;;; Entry Header +;;; This is invoked by the top level of the LAP generator. + +(define (generate/quotation-header environment-label + free-ref-offset n-sections) + (let ((label (generate-label))) + (declare-block-label! (continuation-code-word false) false label) + (use-invoke-interface! 4) + (LAP "current_block[" ,environment-label + "] = register_block[REGBLOCK_ENV];\n\t" + "INVOKE_INTERFACE_4 (" ,code:compiler-link + ", ¤t_block[" ,(label->offset label) "]" + ",\n\t\t\t\tcurrent_block" + ",\n\t\t\t\t¤t_block[" ,free-ref-offset "]" + ",\n\t\t\t\t" ,n-sections ");\n\t" + ,@(label-statement label)))) + +(define (generate/remote-link code-block-label + environment-offset + free-ref-offset + n-sections) + (let ((label (generate-label))) + (add-remote-link! code-block-label) + (declare-block-label! (continuation-code-word false) false label) + (use-invoke-interface! 4) + (LAP "{\n\t SCHEME_OBJECT * subblock = (OBJECT_ADDRESS (current_block[" + ,code-block-label "]));\n\t " + "subblock[" ,environment-offset + "] = register_block[REGBLOCK_ENV];\n\t " + "INVOKE_INTERFACE_4 (" ,code:compiler-link + ", ¤t_block[" ,(label->offset label) "]" + ",\n\t\t\t\t subblock" + ",\n\t\t\t\t &subblock[" ,free-ref-offset "]" + ",\n\t\t\t\t" ,n-sections ");\n\t}\n\t" + ,@(label-statement label)))) + +(define (add-remote-link! label) + (if (not *purification-root-object*) + (set! *purification-root-object* + (cons *purification-root-marker* '()))) + (set-cdr! *purification-root-object* + (cons (object-label-value label) + (cdr *purification-root-object*))) + unspecific) + +(define *purification-root-marker* + (intern "#[PURIFICATION-ROOT]")) + +(define (generate/remote-links n-code-blocks code-blocks-label n-sections) + (define-integrable max-line-width 80) + + (define (sections->c-sections mul? posn n-sections) + (cond ((not (null? n-sections)) + (let* ((val (number->string (car n-sections))) + (next (+ posn (+ 2 (string-length val))))) + (if (>= (1+ next) max-line-width) + (LAP ",\n\t\t" ,val + ,@(sections->c-sections true + (+ 16 (string-length val)) + (cdr n-sections))) + (LAP ", " ,val + ,@(sections->c-sections mul? next (cdr n-sections)))))) + ((or mul? (>= (+ posn 2) max-line-width)) + (LAP "\n\t ")) + (else + (LAP)))) + + (let ((label (generate-label)) + (done (generate-label))) + (set! *purification-root-object* + (cons *purification-root-marker* + (object-label-value code-blocks-label))) + (declare-block-label! (continuation-code-word false) false label) + (use-invoke-interface! 4) + (LAP "*--stack_pointer = (LONG_TO_UNSIGNED_FIXNUM (1L));\n\t" + ,@(label-statement label) + "{\n\t " + "static const short sections []\n\t = {\t0" + ,@(sections->c-sections false 17 (vector->list n-sections)) + "};\n\t " + "long counter = (OBJECT_DATUM (* stack_pointer));\n\t " + "SCHEME_OBJECT blocks, * subblock;\n\t " + "short section;\n\t\n\t " + "if (counter > " ,n-code-blocks "L)\n\t goto " ,done ";\n\t " + "blocks = current_block[" ,code-blocks-label "];\n\t " + "subblock = (OBJECT_ADDRESS (MEMORY_REF (blocks, counter)));\n\t " + "subblock[(OBJECT_DATUM (subblock[0]))]\n\t " + " = register_block[REGBLOCK_ENV];\n\t " + "section = sections[counter];\n\t " + "counter += 1;\n\t " + "*stack_pointer = (LONG_TO_UNSIGNED_FIXNUM (counter));\n\t " + "INVOKE_INTERFACE_4 (" ,code:compiler-link + ", ¤t_block[" ,(label->offset label) "]" + ",\n\t\t\t\t subblock" + ",\n\t\t\t\t (subblock" + "\n\t\t\t\t + (2 + (OBJECT_DATUM (subblock[1]))))" + ",\n\t\t\t\t section);\n\t}\n\t" + ,@(label-statement done) + "stack_pointer += 1;\n\t"))) + +#| +(define (generate/constants-block constants references assignments uuo-links + global-links static-vars) + (let ((constant-info + (declare-constants 0 (transmogrifly uuo-links) + (declare-constants 1 references + (declare-constants 2 assignments + (declare-constants 3 (transmogrifly global-links) + (declare-constants false + (map (lambda (pair) + (cons false (cdr pair))) + static-vars) + (declare-constants false constants + (cons false (LAP)))))))))) + (let ((free-ref-label (car constant-info)) + (constants-code (cdr constant-info)) + (debugging-information-label (allocate-constant-label)) + (environment-label (allocate-constant-label)) + (n-sections + (+ (if (null? uuo-links) 0 1) + (if (null? references) 0 1) + (if (null? assignments) 0 1) + (if (null? global-links) 0 1)))) + (values + (LAP ,@constants-code + ;; Place holder for the debugging info filename + (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO) + ;; Place holder for the load time environment if needed + (SCHEME-OBJECT ,environment-label + ,(if (null? free-ref-label) 0 'ENVIRONMENT))) + environment-label + free-ref-label + n-sections)))) + +(define (declare-constants tag constants info) + (define (inner constants) + (if (null? constants) + (cdr info) + (let ((entry (car constants))) + (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry)) + ,@(inner (cdr constants)))))) + (if (and tag (not (null? constants))) + (let ((label (allocate-constant-label))) + (cons label + (inner + `((,(let ((datum (length constants))) + (if (> datum #xffff) + (error "datum too large" datum)) + (+ (* tag #x10000) datum)) + . ,label) + ,@constants)))) + (cons (car info) (inner constants)))) + +(define (transmogrifly uuos) + (define (inner name assoc) + (if (null? assoc) + (transmogrifly (cdr uuos)) + ;; produces ((name . label) (0 . label) ... (frame-size . label) ...) + ;; where the (0 . label) is repeated to fill out the size required + ;; as specified in machin.scm + `((,name . ,(cdar assoc)) ; uuo-label + (,(caar assoc) . ; frame-size + ,(allocate-constant-label)) + ,@(inner name (cdr assoc))))) + (if (null? uuos) + '() + ;; caar is name, cdar is alist of frame sizes + (inner (caar uuos) (cdar uuos)))) +|# + +;;; Local Variables: *** +;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** +;;; End: *** diff --git a/v7/src/compiler/machines/C/rules4.scm b/v7/src/compiler/machines/C/rules4.scm new file mode 100644 index 000000000..5ba419dc6 --- /dev/null +++ b/v7/src/compiler/machines/C/rules4.scm @@ -0,0 +1,143 @@ +#| -*-Scheme-*- + +$Id: rules4.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Interpreter Calls +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Variable cache trap handling. + +(define-rule statement + (INTERPRETER-CALL:CACHE-REFERENCE (? cont) + (REGISTER (? extension)) + (? safe?)) + (let ((extension (standard-source! extension 'SCHEME_OBJECT*))) + (use-invoke-interface! 2) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_2 (" + ,(if safe? + code:compiler-safe-reference-trap + code:compiler-reference-trap) + ", ¤t_block[" ,(label->offset cont) "], " + ,extension ");\n\t"))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) + (REGISTER (? extension)) + (REGISTER (? value))) + (let ((value (standard-source! value 'SCHEME_OBJECT)) + (extension (standard-source! extension 'SCHEME_OBJECT*))) + (use-invoke-interface! 3) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_3 (" + ,code:compiler-assignment-trap + ", ¤t_block[" ,(label->offset cont) "], " + ,extension + ", " ,value ");\n\t"))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) + (REGISTER (? extension))) + (let ((extension (standard-source! extension 'SCHEME_OBJECT*))) + (use-invoke-interface! 2) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_2 (" ,code:compiler-unassigned?-trap + ", ¤t_block[" ,(label->offset cont) "], " + ,extension ");\n\t"))) + +;;;; Interpreter Calls + +;;; All the code that follows is obsolete. It hasn't been used in a while. +;;; It is provided in case the relevant switches are turned off, but there +;;; is no real reason to do this. Perhaps the switches should be removed. + +(define-rule statement + (INTERPRETER-CALL:ACCESS (? cont) + (REGISTER (? environment)) + (? name)) + (lookup-call code:compiler-access cont environment name)) + +(define-rule statement + (INTERPRETER-CALL:LOOKUP (? cont) + (REGISTER (? environment)) + (? name) + (? safe?)) + (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup) + cont + environment + name)) + +(define-rule statement + (INTERPRETER-CALL:UNASSIGNED? (? cont) + (REGISTER (? environment)) + (? name)) + (lookup-call code:compiler-unassigned? cont environment name)) + +(define-rule statement + (INTERPRETER-CALL:UNBOUND? (REGISTER (? environment)) (? name)) + (lookup-call code:compiler-unbound? environment name)) + +(define (lookup-call code cont environment name) + (let ((environment (standard-source! environment 'SCHEME_OBJECT))) + (use-invoke-interface! 3) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_3 (" ,code + ", ¤t_block[" ,(label->offset cont) "], " + ,environment ", " + "current_block[" ,(object->offset name) "]);\n\t"))) + +(define-rule statement + (INTERPRETER-CALL:DEFINE (? cont) + (REGISTER (? environment)) + (? name) + (REGISTER (? value))) + (assignment-call code:compiler-define cont environment name value)) + +(define-rule statement + (INTERPRETER-CALL:SET! (? cont) + (REGISTER (? environment)) + (? name) + (REGISTER (? value))) + (assignment-call code:compiler-set! cont environment name value)) + +(define (assignment-call code cont environment name value) + (let ((environment (standard-source! environment 'SCHEME_OBJECT)) + (value (standard-source! value 'SCHEME_OBJECT))) + (use-invoke-interface! 4) + (LAP ,@(clear-map!) + "INVOKE_INTERFACE_4 (" ,code + ", ¤t_block[" ,(label->offset cont) "], " + ,environment ", " + "current_block[" ,(object->offset name) "], " ,value ");\n\t"))) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/rulfix.scm b/v7/src/compiler/machines/C/rulfix.scm new file mode 100644 index 000000000..a9bb8a235 --- /dev/null +++ b/v7/src/compiler/machines/C/rulfix.scm @@ -0,0 +1,500 @@ +#| -*-Scheme-*- + +$Id: rulfix.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Fixnum Rules +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Conversions + +(define (object->fixnum source target) + (LAP ,target " = (FIXNUM_TO_LONG (" ,source "));\n\t")) + +(define (address->fixnum source target) + (LAP ,target " = (ADDRESS_TO_LONG (" ,source "));\n\t")) + +(define (fixnum->object source target) + (LAP ,target " = (LONG_TO_FIXNUM (" ,source "));\n\t")) + +(define (fixnum->address source target) + (LAP ,target " = (LONG_TO_ADDRESS (" ,source "));\n\t")) + +(define-rule statement + ;; convert a fixnum object to a "fixnum integer" + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source)))) + (standard-unary-conversion source 'SCHEME_OBJECT target 'LONG + object->fixnum)) + +(define-rule statement + ;; load a fixnum constant as a "fixnum integer" + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant)))) + (let ((target (standard-target! target 'LONG))) + (LAP ,target " = " ,(longify constant) ";\n\t"))) + +(define-rule statement + ;; convert a memory address to a "fixnum integer" + (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source)))) + (standard-unary-conversion source 'SCHEME_OBJECT* target 'LONG + address->fixnum)) + +(define-rule statement + ;; convert an object's address to a "fixnum integer" + (ASSIGN (REGISTER (? target)) + (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source))))) + (standard-unary-conversion source 'SCHEME_OBJECT target 'LONG + object->fixnum)) + +(define-rule statement + ;; convert a "fixnum integer" to a fixnum object + (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source)))) + (standard-unary-conversion source 'LONG target 'SCHEME_OBJECT + fixnum->object)) + +(define-rule statement + ;; convert a "fixnum integer" to a memory address + (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source)))) + (standard-unary-conversion source 'LONG target 'SCHEME_OBJECT* + fixnum->address)) + +;; "Fixnum" in this context means a C long + +(define (no-overflow-branches!) + (set-current-branches! + (lambda (if-overflow) + if-overflow + (LAP)) + (lambda (if-no-overflow) + (LAP "goto " ,if-no-overflow ";\n\t")))) + +(define (standard-overflow-branches! overflow? result) + (if overflow? + (set-current-branches! + (lambda (if-overflow) + (LAP "if (!( LONG_TO_FIXNUM_P (" ,result ")))\n\t goto " + ,if-overflow ";\n\t")) + (lambda (if-not-overflow) + (LAP "if ( LONG_TO_FIXNUM_P (" ,result "))\n\t goto " + ,if-not-overflow ";\n\t")))) + unspecific) + +(define (guarantee-signed-fixnum n) + (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n)) + n) + +(define (signed-fixnum? n) + (and (exact-integer? n) + (>= n signed-fixnum/lower-limit) + (< n signed-fixnum/upper-limit))) + +;;;; Arithmetic Operations + +(define-rule statement + ;; execute a unary fixnum operation + (ASSIGN (REGISTER (? target)) + (FIXNUM-1-ARG (? operation) + (REGISTER (? source)) + (? overflow?))) + (standard-unary-conversion source 'LONG target 'LONG + (lambda (source target) + ((fixnum-1-arg/operator operation) target source overflow?)))) + +(define (fixnum-1-arg/operator operation) + (lookup-arithmetic-method operation fixnum-methods/1-arg)) + +(define fixnum-methods/1-arg + (list 'FIXNUM-METHODS/1-ARG)) + +(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg + (lambda (tgt src overflow?) + (fixnum-add-constant tgt src 1 overflow?))) + +(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg + (lambda (tgt src overflow?) + (fixnum-add-constant tgt src -1 overflow?))) + +(define (fixnum-add-constant tgt src constant overflow?) + (standard-overflow-branches! overflow? tgt) + (cond ((back-end:= constant 0) + (LAP ,tgt " = " ,src ";\n\t")) + ((and (number? constant) (< constant 0)) + (LAP ,tgt " = (" ,src " - " ,(- constant) "L);\n\t")) + (else + (LAP ,tgt " = (" ,src " + " ,(longify constant) ");\n\t")))) + +(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg + (lambda (tgt src1 overflow?) + (if overflow? (no-overflow-branches!)) + (LAP ,tgt " = ( ~ " ,src1 ");\n\t"))) + +(define-rule statement + ;; execute a binary fixnum operation + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + (standard-binary-conversion source1 'LONG source2 'LONG target 'LONG + (lambda (source1 source2 target) + ((fixnum-2-args/operator operation) target source1 source2 overflow?)))) + +(define (fixnum-2-args/operator operation) + (lookup-arithmetic-method operation fixnum-methods/2-args)) + +(define fixnum-methods/2-args + (list 'FIXNUM-METHODS/2-ARGS)) + +(let-syntax + ((binary-fixnum + (macro (name instr) + `(define-arithmetic-method ',name fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (if overflow? (no-overflow-branches!)) + (LAP ,',tgt " = (" ,',src1 ,instr ,',src2 ");\n\t")))))) + + (binary-fixnum FIXNUM-AND " & ") + (binary-fixnum FIXNUM-OR " | ") + (binary-fixnum FIXNUM-XOR " ^ ") + (binary-fixnum FIXNUM-ANDC " & ~ ")) + +(let-syntax + ((binary-fixnum + (macro (name instr) + `(define-arithmetic-method ',name fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (if overflow? (no-overflow-branches!)) + (LAP ,',tgt + " = (" ,instr " (" ,',src1 ", " ,',src2 "));\n\t")))))) + + (binary-fixnum FIXNUM-REMAINDER "FIXNUM_REMAINDER") + (binary-fixnum FIXNUM-LSH "FIXNUM_LSH")) + +(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (standard-overflow-branches! overflow? tgt) + (LAP ,tgt " = (FIXNUM_QUOTIENT (" ,src1 ", " ,src2 "));\n\t"))) + +(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (standard-overflow-branches! overflow? tgt) + (LAP ,tgt " = (" ,src1 " + " ,src2 ");\n\t"))) + +(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (if overflow? + (if (eqv? src1 src2) ;probably won't ever happen. + (begin + (no-overflow-branches!) + ; we don't use zero directly because we care about the tag + (LAP ,tgt " = (" ,src2 " - " ,src2 ");\n\t")) + (do-overflow-subtraction tgt src1 src2)) + (LAP ,tgt " = (" ,src1 " - " ,src2 ");\n\t")))) + +(define (do-overflow-subtraction tgt src1 src2) + (standard-overflow-branches! true tgt) + (LAP ,tgt " = (" ,src1 " - " ,src2 ");\n\t")) + +(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args + (lambda (target src1 src2 overflow?) + (if (not overflow?) + (LAP ,target " = (" ,src1 " * " ,src2 ");\n\t") + (overflow-product! target src1 src2)))) + +(define (overflow-product! target src1 src2) + (set-current-branches! + (lambda (if-overflow-label) + (LAP "if (multiply_with_overflow ( " ,src1 ", " ,src2 ", &" ,target + "))\n\t goto " ,if-overflow-label ";\n\t")) + (lambda (if-not-overflow-label) + (LAP "if (!(multiply_with_overflow ( " ,src1 ", " ,src2 ", &" ,target + ")))\n\t goto " ,if-not-overflow-label ";\n\t"))) + (LAP)) + +(define-rule statement + ;; execute binary fixnum operation with constant second arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source)) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (? overflow?))) + (standard-unary-conversion source 'LONG target 'LONG + (lambda (source target) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?)))) + +(define-rule statement + ;; execute binary fixnum operation with constant first arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (REGISTER (? source)) + (? overflow?))) + (QUALIFIER (not (memq operation + '(FIXNUM-QUOTIENT FIXNUM-REMAINDER FIXNUM-LSH)))) + (standard-unary-conversion source 'LONG target 'LONG + (lambda (source target) + (if (fixnum-2-args/commutative? operation) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?) + ((fixnum-2-args/operator/constant*register operation) + target constant source overflow?))))) + +(define (fixnum-2-args/commutative? operator) + (memq operator + '(PLUS-FIXNUM MULTIPLY-FIXNUM FIXNUM-AND FIXNUM-OR FIXNUM-XOR))) + +(define (fixnum-2-args/operator/register*constant operation) + (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant)) + +(define fixnum-methods/2-args/register*constant + (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT)) + +(define (fixnum-2-args/operator/constant*register operation) + (lookup-arithmetic-method operation + fixnum-methods/2-args/constant*register)) + +(define fixnum-methods/2-args/constant*register + (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER)) + +(define-arithmetic-method 'PLUS-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (fixnum-add-constant tgt src constant overflow?))) + +(define-arithmetic-method 'MINUS-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (fixnum-add-constant tgt src + (back-end:- 0 constant) + overflow?))) + +(define (power-of-2? value) + (let loop ((n value)) + (and (> n 0) + (if (= n 1) + 0 + (and (even? n) + (let ((m (loop (quotient n 2)))) + (and m + (+ m 1)))))))) + +(define-arithmetic-method 'MULTIPLY-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (cond ((back-end:= constant 0) + (if overflow? (no-overflow-branches!)) + (LAP ,tgt " = 0L;\n\t")) + ((back-end:= constant 1) + (if overflow? (no-overflow-branches!)) + (LAP ,tgt " = " ,src ";\n\t")) + ((and (number? constant) + (power-of-2? (abs constant))) + => + (lambda (power-of-two) + (if (not overflow?) + (LAP ,tgt + ,(if (negative? constant) + " = (- " + " = ") + "(LEFT_SHIFT (" ,src ", " ,power-of-two + "))" + ,(if (negative? constant) + ")" + "") + ";\n\t") + (overflow-product! tgt src constant)))) + ((not overflow?) + (LAP ,tgt " = (" ,src " * " ,(longify constant) ");\n\t")) + (else + (overflow-product! tgt src constant))))) + +(define-arithmetic-method 'MINUS-FIXNUM + fixnum-methods/2-args/constant*register + (lambda (tgt constant src overflow?) + (guarantee-signed-fixnum constant) + (if overflow? + (do-overflow-subtraction tgt constant src) + (LAP ,tgt " = (" ,constant " - " ,src ");\n\t")))) + +(define-arithmetic-method 'FIXNUM-QUOTIENT + fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (cond ((back-end:= constant 0) + (error "fixnum-quotient constant division by zero.")) + ((back-end:= constant 1) + (if overflow? (no-overflow-branches!)) + (LAP ,tgt " = " ,src ";\n\t")) + ((back-end:= constant -1) + (standard-overflow-branches! overflow? tgt) + (LAP ,tgt " = - " ,src ";\n\t")) + ((and (number? constant) + (power-of-2? (abs constant))) + => + (lambda (power-of-two) + (if overflow? + (no-overflow-branches!)) + (LAP ,tgt + ,(if (negative? constant) + " = (- " + " = ") + "((" ,src " < 0) ? (RIGHT_SHIFT ((" ,src " + " + ,(-1+ (abs constant)) "), " ,power-of-two "))" + " : (RIGHT_SHIFT (" ,src " ," ,power-of-two ")))" + ,(if (negative? constant) + ")" + "") + ";\n\t"))) + (else + (standard-overflow-branches! overflow? tgt) + (LAP ,tgt " = (FIXNUM_QUOTIENT (" ,src ", " ,(longify constant) + "));\n\t"))))) + +(define-arithmetic-method 'FIXNUM-REMAINDER + fixnum-methods/2-args/register*constant + (lambda (tgt src s-constant overflow?) + (let ((constant (abs s-constant))) + (if overflow? (no-overflow-branches!)) + (cond ((back-end:= constant 0) + (error "fixnum-remainder constant division by zero.")) + ((back-end:= constant 1) + (LAP ,tgt " = 0;\n\t")) + ((and (number? constant) + (power-of-2? constant)) + => + (lambda (power-of-two) + (LAP "{\n\t long temp = (" ,src " & " ,(-1+ constant) + "L);\n\t " + ,tgt " = ((" ,src " >= 0) ? temp : ((temp == 0) ? 0" + " : (temp | (LEFT_SHIFT (-1L, " ,power-of-two + ")))));\n\t}\n\t"))) + (else + (LAP ,tgt " = (FIXNUM_REMAINDER (" ,src ", " ,(longify constant) + "));\n\t")))))) + +(define-arithmetic-method 'FIXNUM-LSH + fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (cond (overflow? + (error "fixnum-lsh overflow what??")) + ((back-end:= constant 0) + (LAP ,tgt " = " ,src ";\n\t")) + ((not (number? constant)) + (LAP ,tgt " = (FIXNUM_LSH (" ,src ", " ,constant "));\n\t")) + ((positive? constant) + (LAP ,tgt " = (LEFT_SHIFT (" ,src ", " ,constant "));\n\t")) + (else + (LAP "{\n\t unsigned long temp = ((unsigned long) " ,src ");\n\t " + ,tgt " = ((long) (RIGHT_SHIFT_UNSIGNED (temp, " ,(- constant) + ")));\n\t}\n\t"))))) + +(let-syntax + ((binary-fixnum + (macro (name instr) + `(define-arithmetic-method ',name + fixnum-methods/2-args/register*constant + (lambda (tgt src1 constant overflow?) + (if overflow? (no-overflow-branches!)) + (LAP ,',tgt " = (" ,',src1 ,instr ,',(longify constant) ");\n\t")))))) + + (binary-fixnum FIXNUM-AND " & ") + (binary-fixnum FIXNUM-OR " | ") + (binary-fixnum FIXNUM-XOR " ^ ") + (binary-fixnum FIXNUM-ANDC " & ~ ")) + +(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args/constant*register + (lambda (tgt constant src2 overflow?) + (if overflow? (no-overflow-branches!)) + (LAP ,tgt " = (" ,(longify constant) " & ~ " ,src2 ");\n\t"))) + +;;;; Predicates + +(define-rule predicate + (OVERFLOW-TEST) + ;; The RTL code generate guarantees that this instruction is always + ;; immediately preceded by a fixnum operation with the OVERFLOW? + ;; flag turned on. Furthermore, it also guarantees that there are + ;; no other fixnum operations with the OVERFLOW? flag set. So all + ;; the processing of overflow tests has been moved into the fixnum + ;; operations. + (LAP)) + +(define-rule predicate + (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source))) + (compare (case predicate + ((ZERO-FIXNUM?) " == ") + ((NEGATIVE-FIXNUM?) " < ") + ((POSITIVE-FIXNUM?) " > ") + (else (error "unknown fixnum predicate" predicate))) + (standard-source! source 'LONG) + "0")) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (compare (fixnum-pred-2->cc predicate) + (standard-source! source1 'LONG) + (standard-source! source2 'LONG))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (REGISTER (? source)) + (OBJECT->FIXNUM (CONSTANT (? constant)))) + (compare (fixnum-pred-2->cc predicate) + (standard-source! source 'LONG) + (longify constant))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (REGISTER (? source))) + (compare (fixnum-pred-2->cc predicate) + (longify constant) + (standard-source! source 'LONG))) + +(define (fixnum-pred-2->cc predicate) + (case predicate + ((EQUAL-FIXNUM?) " == ") + ((LESS-THAN-FIXNUM?) " < ") + ((GREATER-THAN-FIXNUM?) " > ") + (else + (error "unknown fixnum predicate" predicate)))) + +(define (longify constant) + (if (number? constant) + (string-append (number->string constant) + "L") + constant)) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/rulflo.scm b/v7/src/compiler/machines/C/rulflo.scm new file mode 100644 index 000000000..b6186ab8e --- /dev/null +++ b/v7/src/compiler/machines/C/rulflo.scm @@ -0,0 +1,135 @@ +#| -*-Scheme-*- + +$Id: rulflo.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Flonum rules +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Flonum Arithmetic + +(define-rule statement + ;; convert a floating-point number to a flonum object + (ASSIGN (REGISTER (? target)) + (FLOAT->OBJECT (REGISTER (? source)))) + (let ((source (standard-source! source 'double))) + (let ((target (standard-target! target 'SCHEME_OBJECT))) + (LAP "INLINE_DOUBLE_TO_FLONUM (" ,source ", " ,target ");\n\t")))) + +(define-rule statement + ;; convert a flonum object to a floating-point number + (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source)))) + (let ((source (standard-source! source 'SCHEME_OBJECT))) + (let ((target (standard-target! target 'double))) + (LAP ,target " = (FLONUM_TO_DOUBLE (" ,source "));\n\t")))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?))) + overflow? ;ignore + (let ((source (standard-source! source 'double))) + ((flonum-1-arg/operator operation) + (standard-target! target 'double) + source))) + +(define (flonum-1-arg/operator operation) + (lookup-arithmetic-method operation flonum-methods/1-arg)) + +(define flonum-methods/1-arg + (list 'FLONUM-METHODS/1-ARG)) + +(define-arithmetic-method 'FLONUM-ABS flonum-methods/1-arg + (lambda (target source) + (LAP ,target " = ((" ,source " >= 0.) ? " ,source " : (-" ,source + "));\n\t"))) + +(define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg + (lambda (target source) + (LAP ,target " = (- " ,source ");\n\t"))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + overflow? ;ignore + (let ((source1 (standard-source! source1 'double)) + (source2 (standard-source! source2 'double))) + ((flonum-2-args/operator operation) + (standard-target! target 'double) + source1 + source2))) + +(define (flonum-2-args/operator operation) + (lookup-arithmetic-method operation flonum-methods/2-args)) + +(define flonum-methods/2-args + (list 'FLONUM-METHODS/2-ARGS)) + +(let-syntax + ((define-flonum-operation + (macro (primitive-name opcode) + `(define-arithmetic-method ',primitive-name flonum-methods/2-args + (lambda (target source1 source2) + (LAP ,',target " = (" ,',source1 ,opcode ,',source2 + ");\n\t")))))) + (define-flonum-operation flonum-add " + ") + (define-flonum-operation flonum-subtract " - ") + (define-flonum-operation flonum-multiply " * ") + (define-flonum-operation flonum-divide " / ")) + +;;;; Flonum Predicates + +(define-rule predicate + (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source))) + (compare (case predicate + ((FLONUM-ZERO?) " == ") + ((FLONUM-NEGATIVE?) " < ") + ((FLONUM-POSITIVE?) " > ") + (else (error "unknown flonum predicate" predicate))) + (standard-source! source 'double) + "0.0")) + +(define-rule predicate + (FLONUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (compare (case predicate + ((FLONUM-EQUAL?) " == ") + ((FLONUM-LESS?) " < ") + ((FLONUM-GREATER?) " > ") + (else (error "unknown flonum predicate" predicate))) + (standard-source! source1 'double) + (standard-source! source2 'double))) \ No newline at end of file diff --git a/v7/src/compiler/machines/C/rulrew.scm b/v7/src/compiler/machines/C/rulrew.scm new file mode 100644 index 000000000..65e52c47a --- /dev/null +++ b/v7/src/compiler/machines/C/rulrew.scm @@ -0,0 +1,149 @@ +#| -*-Scheme-*- + +$Id: rulrew.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Rewrite Rules +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; 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-constant 0))) + +(define-rule rewriting + (EQ-TEST (? source) (REGISTER (? comparand register-known-value))) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'EQ-TEST source (rtl:make-machine-constant 0))) + +(define-rule rewriting + (EQ-TEST (REGISTER (? comparand register-known-value)) (? source)) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'EQ-TEST source (rtl:make-machine-register 0))) + +(define (rtl:immediate-zero-constant? expression) + (cond ((rtl:constant? expression) + (let ((value (rtl:constant-value expression))) + (and (non-pointer-object? value) + (zero? (object-type value)) + (zero? (object-datum value))))) + ((rtl:cons-non-pointer? expression) + (and (let ((expression (rtl:cons-non-pointer-type expression))) + (and (rtl:machine-constant? expression) + (zero? (rtl:machine-constant-value expression)))) + (let ((expression (rtl:cons-non-pointer-datum expression))) + (and (rtl:machine-constant? expression) + (zero? (rtl:machine-constant-value expression)))))) + (else false))) + +;;; Fixnums + +(define-rule rewriting + (OBJECT->FIXNUM (REGISTER (? source register-known-value))) + (QUALIFIER (rtl:constant-fixnum? source)) + (rtl:make-object->fixnum source)) + +(define (rtl:constant-fixnum? expression) + (and (rtl:constant? expression) + (fix:fixnum? (rtl:constant-value expression)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/assmd.scm b/v7/src/compiler/machines/sparc/assmd.scm new file mode 100644 index 000000000..2e6c8f25b --- /dev/null +++ b/v7/src/compiler/machines/sparc/assmd.scm @@ -0,0 +1,95 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/assmd.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ +$MC68020-Header: assmd.scm,v 1.36 89/08/28 18:33:33 GMT cph Exp $ + +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Assembler Machine Dependencies + +(declare (usual-integrations)) + +(let-syntax ((ucode-type (macro (name) `',(microcode-type name)))) + +(define-integrable maximum-padding-length + ;; Instruction length is always a multiple of 32 bits + ;; Would 0 work here? + 32) + +(define padding-string + ;; Pad with `UNIMP' instructions + (unsigned-integer->bit-string maximum-padding-length + #b00000000000000000000000000000000 )) + +(define-integrable block-offset-width + ;; Block offsets are always 16 bit words + 16) + +(define-integrable maximum-block-offset + ;; PC always aligned on longword boundary. Use the extra bit. + (- (expt 2 (1+ block-offset-width)) 4)) + +(define (block-offset->bit-string offset start?) + (unsigned-integer->bit-string block-offset-width + (+ (quotient offset 2) + (if start? 0 1)))) + +(define (make-nmv-header n) + (bit-string-append (unsigned-integer->bit-string scheme-datum-width n) + nmv-type-string)) + +(define nmv-type-string + (unsigned-integer->bit-string scheme-type-width + (ucode-type manifest-nm-vector))) + +(define (object->bit-string object) + (bit-string-append + (unsigned-integer->bit-string scheme-datum-width + (careful-object-datum object)) + (unsigned-integer->bit-string scheme-type-width (object-type object)))) + +;;; Machine dependent instruction order + +(define (instruction-insert! bits block position receiver) + (let ((l (bit-string-length bits))) + (if (eq? endianness 'LITTLE) + (begin + (bit-substring-move-right! bits 0 l block position) + (receiver (+ position l))) + (let ((new-position (- position l))) + (bit-substring-move-right! bits 0 l block new-position) + (receiver new-position))))) + +(define-integrable instruction-initial-position bit-string-length) +(define-integrable instruction-append bit-string-append-reversed) + +;;; end let-syntax +) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/cf.h-sparc b/v7/src/compiler/machines/sparc/cf.h-sparc new file mode 100644 index 000000000..8bcc94bcf --- /dev/null +++ b/v7/src/compiler/machines/sparc/cf.h-sparc @@ -0,0 +1,85 @@ +/* -*-C-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/cf.h-sparc,v 1.1 1993/06/08 06:11:57 gjr Exp $ + +Copyright (c) 1989-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +#define PROC_TYPE_UNKNOWN 0 +#define PROC_TYPE_68000 1 +#define PROC_TYPE_68020 2 +#define PROC_TYPE_HPPA 3 /* HP Precision Architecture */ +#define PROC_TYPE_VAX 4 +#define PROC_TYPE_MIPS 5 +#define PROC_TYPE_NS32K 6 +#define PROC_TYPE_HCX 7 /* Harris HCX */ +#define PROC_TYPE_IBM032 8 /* IBM RT */ +#define PROC_TYPE_SPARC 9 +#define PROC_TYPE_I386 10 +#define PROC_TYPE_ALPHA 11 +#define PROC_TYPE_POWER 12 /* IBM RS6000 and PowerPC */ + +/* Define this macro to use a non-standard compiler. + It must be defined before including the m/ and s/ files because + they may be conditionalized on it. */ + +#define ALTERNATE_CC gcc-2.3.3 + +/* Define this macro to use a non-standard assembler. */ +/* #define ALTERNATE_AS gashp */ + +#include "s.h" +#include "m.h" + +#ifndef PROC_TYPE +#define PROC_TYPE PROC_TYPE_UNKNOWN +#endif + +/* Define HAVE_X_WINDOWS if you want to use the X window system. */ +#define HAVE_X_WINDOWS + +/* Define HAVE_STARBASE_GRAPHICS if you want Starbase graphics support. + This is specific to HP-UX. */ +/* #define HAVE_STARBASE_GRAPHICS */ +/* #define STARBASE_DEVICE_DRIVERS -ldd300h -ldd98700 -ldd98710 -ldd98556 */ + +/* Some compilation options: + -DDISABLE_HISTORY turns off history recording mechanism */ +#define C_SWITCH_FEATURES + +/* The following two switches are mutually exclusive for most C compilers. + An exception is the GNU C compiler. */ + +/* If defined, this prevents the C compiler from running its optimizer. */ +#define SUPPRESS_C_OPTIMIZER + +/* If defined, this prevents the C compiler from + generating debugging information. */ +#define SUPPRESS_C_DEBUGGING diff --git a/v7/src/compiler/machines/sparc/cmpaux-sparc.m4 b/v7/src/compiler/machines/sparc/cmpaux-sparc.m4 new file mode 100644 index 000000000..eb4fbf1de --- /dev/null +++ b/v7/src/compiler/machines/sparc/cmpaux-sparc.m4 @@ -0,0 +1,356 @@ +/* #define DEBUG_INTERFACE */ /* -*-Midas-*- */ + !### + !### $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/cmpaux-sparc.m4,v 1.1 1993/06/08 06:11:57 gjr Exp $ + !### + !### Copyright (c) 1989-1992 Massachusetts Institute of Technology + !### + !### This material was developed by the Scheme project at the + !### Massachusetts Institute of Technology, Department of + !### Electrical Engineering and Computer Science. Permission to + !### copy this software, to redistribute it, and to use it for any + !### purpose is granted, subject to the following restrictions and + !### understandings. + !### + !### 1. Any copy made of this software must include this copyright + !### notice in full. + !### + !### 2. Users of this software agree to make their best efforts (a) + !### to return to the MIT Scheme project any improvements or + !### extensions that they make, so that these may be included in + !### future releases; and (b) to inform MIT of noteworthy uses of + !### this software. + !### + !### 3. All materials developed as a consequence of the use of this + !### software shall duly acknowledge such use, in accordance with + !### the usual standards of acknowledging credit in academic + !### research. + !### + !### 4. MIT has made no warrantee or representation that the + !### operation of this software will be error-free, and MIT is + !### under no obligation to provide any services, by way of + !### maintenance, update, or otherwise. + !### + !### 5. In conjunction with products arising from the use of this + !### material, there shall be no use of the name of the + !### Massachusetts Institute of Technology nor of any adaptation + !### thereof in any advertising, promotional, or sales literature + !### without prior written consent from MIT in each case. + !### + + !#### SPARC Architecture assembly language part of the compiled + !#### code interface. See cmpint.txt, cmpint.c, cmpint-mips.h, and + !#### cmpgc.h for more documentation. + !#### + !#### NOTE: + !#### Assumptions: + !#### + !#### 1) All registers (except double floating point registers) and + !#### stack locations hold a C long object. + !#### + !#### 2) The C compiler divides registers into four categories: + !#### in: (%i7-%i0 or %r31-%r24) incoming parameters + !#### note: %fp is in this group + !#### note: %i7 holds the C return address, don't bash this. + !#### + !#### out: (%o7-%o0 or %r15-%r8) outgoing parameters + !#### note: %sp is in this group + !#### + !#### locals: (%l7-%l0 or %r23-%r16) + !#### + !#### globals: (%g7-%g0 or %r7-%r0), reserved, essentially useless + !#### + !#### The ins and locals are callee save through the standard SPARC save + !#### and restore instructions. This has the added effect of cleaning + !#### up the stack and frame pointers correctly. Globals are callee save. + !#### Note that save and restore also pose as simulataneous add + !#### instructions. This comes in handy for allocating the stack frame. + !#### + !#### 3) On SPARC the floating point registers are totally ungoverned. + !#### The de-facto standard is caller save. + + + !#### Compiled Scheme code uses the following register convention. + !#### - g0 is the 0 constant (hardwired) + !#### - g1 is the designated temporary (scheme available) + !#### - g2-g4 are available for globals (scheme available) + !#### - g5-g7 are off limits super globals. (don't touch!) + !#### < Start of C callee saves > + !#### - l0 is the return value register. (scheme available) + !#### - l1 contains the Scheme stack pointer. (scheme available) + !#### - l2 contains a cached version of MemTop. (scheme available) + !#### - l3 contains the Scheme free pointer. (scheme available) + !#### - l4 contains the address of scheme_to_interface. (scheme available) + !#### - l5 contains the dynamic link when needed. (scheme available) + !#### - l6 contains the closure free pointer. (scheme available) + !#### - l7 is leftover (used for tramp index) (scheme available) + !#### - i0 is the C return value / first parameter (scheme available) + !#### - i1 contains the address mask for machine pointers. (scheme available) + !#### - i2 contains a pointer to the Scheme interpreter's (scheme available) + !#### "register" block. This block contains the compiler's + !#### copy of MemTop, the interpreter's registers (val, env, + !#### exp, etc), temporary locations for compiled code. + !#### - i3 contains the top 6 address bits for heap pointers. (scheme available) + !#### - i4 contains the closure hook. (scheme available) + !#### - i5 is leftover. (scheme available) + !#### - i6 is the C frame pointer, alternatively the old C sp.(don't touch!) + !#### - i7 is the C return address. (don't touch!) + !#### < End of C callee saves > + !#### - o7 is the target of call instructions, ie next pc. (scheme available) + !#### - o6 is the current C stack pointer. (scheme available) + !#### - o5-o1 are outgoing parameters to the C world. (scheme available) + !#### - o0 is an outgoing parameter to the C world, and the return value + !#### from there (scheme available) + !#### + + !# .verstamp 1 31 + +define(value, l0) +define(stack, l1) +define(C_arg1, o0) +define(C_arg2, o1) +define(C_arg3, o2) +define(C_arg4, o3) +define(utility_index, o5) + +define(memtop, l2) +define(free, l3) +define(s_to_i, l4) +define(dynlink, l5) + +define(closure_free, l6) +define(addr_mask, i1) +define(registers, i2) +define(heap_bits, i3) +define(closure_reg, i4) + + .global _Free + .global _Registers + .global _Ext_Stack_Pointer + + .text + .align 4 + + + !# Argument (in $C_arg1) is a compiled Scheme entry point + !# but save C registers first + .align 4 + .global _C_to_interface + .proc 020 +_C_to_interface: + save %sp,-104,%sp + + !# Make space for interface return structs and stick a pointer to + !# on the stack. SPARC C calling conventions require this. + + add %fp, -24, %o0 + st %o0,[%sp+64] + + !# Now stick the right interpreter registers into the right machine + !# registers. + + sethi %hi(_Free), %g1 + ld [%g1+%lo(_Free)], %heap_bits + sethi %hi(0xfc000000), %addr_mask + sethi %hi(_Registers), %g1 + or %g1, %lo(_Registers), %registers + and %heap_bits, %addr_mask, %heap_bits + xnor %g0, %addr_mask, %addr_mask + + .align 4 + .global _interface_to_scheme +_interface_to_scheme: + + sethi %hi(_Free), %g1 + ld [%g1+%lo(_Free)], %free + sethi %hi(_Ext_Stack_Pointer), %g1 + ld [%g1+%lo(_Ext_Stack_Pointer)], %stack + + ld [%registers + 36],%closure_free + ld [%registers + 8],%value + ld [%registers],%memtop + + and %value,%addr_mask,%dynlink + or %dynlink,%heap_bits,%dynlink + jmpl %i0 + 0, %o7 + add %o7,264,%s_to_i + +!# Don't rearrange the following procedures. The compiler backend knows their offsets +!# from scheme_to_interface and uses this knowledge to jump to them. + + .align 4 + .global _cons_multi_closure + !# arg1 -> linkage data start address + !# arg2 -> number of entries + !# arg3 -> contains contents of %free + !# %s_to_1 -256 + !# C_arg1 points to a manifest closure header word, followed by + !# nentries two-word structures, followed by the actual + !# instructions to return to. + !# The first word of each descriptor is the format+gc-offset word of + !# the corresponding entry point of the generated closure. + !# The second word is the offset from the entry address to the real + !# code of the closure. +_cons_multi_closure: + save %sp, -96, %sp + add %i0, 0, %l0 + + !# Stuff the tag word and length into the beginning of the multi-closure + !# also write in the number of entries word. + ld [%l0], %g1 + st %g1, [%i2] + add %l0, 4, %l0 + + sll %i1, 16, %g1 + st %g1, [%i2 + 4] + + !# Setup a template for the Addi part of each entry + sethi %hi(0x82006008), %l1 + add %lo(0x82006008), %l1, %l1 + + !# Calcualate the first offset to the closed var. + add %i1, -1, %l2 + umul %l2, 16, %l2 + + !# Copy free and bump it up two words + add %i2, 8, %l3 + +cmc_l2: + !# Copy the format+gc-offset word into the start of the entry + ld [%l0], %g1 + st %g1, [%l3] + + !# Construct the sethi(target) part of the entry + ld [%l0+4], %g1 + add %i0, %g1, %g1 + srl %g1, 10, %l4 + sethi %hi(0x03000000), %l5 + or %l4, %l5, %l5 + st %l5, [%l3+4] + + !# Construct the jmpl(lo(target)) part of the entry + and %g1, 0x3ff, %l4 + sethi %hi(0x83c06000), %l5 + or %l4, %l5, %l5 + st %l5, [%l3+8] + + !# Construct the addi offset-to-data part of the entry + add %l2, %l1, %l5 + st %l5, [%l3+12] + + !# Flush the instruction cache + iflush %l3 + 4 + iflush %l3 + 8 + iflush %l3 + 12 + + !# Bump to the next entry, next set of data + + add %l3, 16, %l3 + add %l0, 8, %l0 + subcc %l2, 16, %l2 + bge cmc_l2 + nop + + add %l0, 0, %g1 + jmpl %g1, %g0 + restore + + .align 4 + .global _cons_closure + !# arg1 -> return address + !# arg2 -> delta from return address + !# arg3 -> closure size (in bytes) + !# arg4 -> using as an extra temp + !# s_to_i -108 +_cons_closure: + ld [%C_arg1], %g1 + st %g1, [%free] + ld [%C_arg1 + 4], %g1 + st %g1, [%free + 4] + add %g0, %g0, %C_arg4 + add %C_arg2, %C_arg1, %C_arg2 + sethi %hi(0x03000000), %C_arg4 + srl %C_arg2, 10, %g1 + add %g1, %C_arg4, %C_arg4 + st %C_arg4, [%free + 8] + sethi %hi(0x83c06000), %C_arg4 + and 0x3ff, %C_arg2, %g1 + add %g1, %C_arg4, %C_arg4 + st %C_arg4, [%free + 12] + sethi %hi(0x82006008), %C_arg4 + add %lo(0x82006008), %C_arg4, %C_arg4 + st %C_arg4, [%free + 16] + iflush %free + 8 + iflush %free + 12 + iflush %free + 16 + add %free, 8, %C_arg2 + add %C_arg3, %free, %free + add %C_arg1, 8, %C_arg1 + jmpl %C_arg1, %g0 + nop + + .align 4 + .global _trampoline_to_interface + !# s_to_i - 8 +_trampoline_to_interface: + add %C_arg1, -4, %C_arg1 + + .align 4 + .global _link_to_interface + !# s_to_i - 4 +_link_to_interface: + add %C_arg1, 12, %C_arg1 + + .align 4 + .global _scheme_to_interface + .proc 020 +_scheme_to_interface: + st %value,[%registers + 8] + st %closure_free,[%registers + 36] + + sethi %hi(_utility_table), %g1 + or %g1, %lo(_utility_table), %g1 !# Find table + add %g1,%utility_index,%g1 !# Address of entry + ld [%g1],%l7 !# l7 <- Entry + nop + sethi %hi(_Ext_Stack_Pointer), %g1 + st %stack,[%g1+%lo(_Ext_Stack_Pointer)] !# Save Scheme stack pointer + nop + sethi %hi(_Free), %g1 + st %free,[%g1+%lo(_Free)] !# Save Free + nop + jmpl %l7 + 0, %o7 !# Off to interface code + nop + unimp 8 + ld [%o0 + 4],%i0 !# Get dispatch address + ld [%o0],%C_arg1 !# Arg1 <- value component + jmpl %C_arg1,%o7 !# Redispatch ... + nop !# Branch delay + + .align 4 + .global _interface_to_C + .proc 020 +_interface_to_C: + add %i0,%g0,%C_arg1 !# Return value to C + ret !# Return to the C universe + restore !# Restore callee save regs + + .align 4 + .global _flushrange + .proc 020 +_flushrange: + save %sp,-96,%sp + !# arg1: address base, arg2: byte count + add %g0, %g0, %l0 +flush_l: + iflush %i0 + %l0 + add 4, %l0, %l0 + subcc %l0,%i1,%g0 + bl flush_l !# Continue if address < address + count + nop + nop !# flush pipeline + nop + nop + nop + nop + ret !# Return to caller + restore !# Restore callee save regs diff --git a/v7/src/compiler/machines/sparc/cmpint-sparc.h b/v7/src/compiler/machines/sparc/cmpint-sparc.h new file mode 100644 index 000000000..884e481a9 --- /dev/null +++ b/v7/src/compiler/machines/sparc/cmpint-sparc.h @@ -0,0 +1,672 @@ +/* -*-C-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/cmpint-sparc.h,v 1.1 1993/06/08 06:11:57 gjr Exp $ + +Copyright (c) 1989-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +/* + * + * Compiled code interface macros. + * + * See cmpint.txt for a description of these fields. + * + * Specialized for the MIPS R2000/R3000 + */ + +#ifndef CMPINT2_H_INCLUDED +#define CMPINT2_H_INCLUDED + +#define ICACHEFLUSH(addr, nbytes) flushrange ((addr), (nbytes)) + +#define COMPILER_NONE_TYPE 0 +#define COMPILER_MC68020_TYPE 1 +#define COMPILER_VAX_TYPE 2 +#define COMPILER_SPECTRUM_TYPE 3 +#define COMPILER_OLD_MIPS_TYPE 4 +#define COMPILER_MC68040_TYPE 5 +#define COMPILER_SPARC_TYPE 6 +#define COMPILER_RS6000_TYPE 7 +#define COMPILER_MC88K_TYPE 8 +#define COMPILER_I386_TYPE 9 +#define COMPILER_ALPHA_TYPE 10 +#define COMPILER_MIPS_TYPE 11 + +/* Machine parameters to be set by the user. */ + +/* Processor type. Choose a number from the above list, or allocate your own. */ + +#define COMPILER_PROCESSOR_TYPE COMPILER_SPARC_TYPE + +/* Size (in long words) of the contents of a floating point register if + different from a double. For example, an MC68881 saves registers + in 96 bit (3 longword) blocks. + Default is fine for MIPS. + define COMPILER_TEMP_SIZE 3 +*/ + +/* Descriptor size. + This is the size of the offset field, and of the format field. + This definition probably does not need to be changed. + */ + +typedef unsigned short format_word; + +/* PC alignment constraint. + Change PC_ZERO_BITS to be how many low order bits of the pc are + guaranteed to be 0 always because of PC alignment constraints. +*/ + +#define PC_ZERO_BITS 2 + +/* Utilities for manipulating absolute subroutine calls. + On the SPARC this is done with: + CALL destination + + The low 30 bits of the instruction form the address. This will + automatically be shifted over 2 bits to adjust for alignment. + */ + +#define EXTRACT_FROM_JAL_INSTR(target, address) \ +{ \ + unsigned long * addr = ((unsigned long *) (address)); \ + unsigned long jal_instr = (*addr); \ + (target) = \ + ((SCHEME_OBJECT) \ + ((((long) (address)) & 0x3FFFFFFF))); \ +} + +#define CALL_OP (0x1 << 30) +#define CALL_INSTR(dest) (CALL_OP | (dest >> 2)) + +#define STORE_JAL_INSTR(entry_point, address) \ +{ \ + unsigned long ep = ((unsigned long) (entry_point)); \ + unsigned long * addr = ((unsigned long *) (address)); \ + if ((((long) addr) & 0x3) != 0) \ + { \ + fprintf (stderr, \ + "\nSTORE_JAL_INSTR: Bad addr in CALL 0x%x, 0x%x\n", \ + addr, ep); \ + } \ + (*addr) = CALL_INSTR (ep); \ +} + +/* Compiled Code Register Conventions */ +/* This must match the compiler and cmpaux-sparc.s */ + +#define COMP_REG_TEMPORARY 1 +#define COMP_REG_RETURN 16 +#define COMP_REG_STACK 17 +#define COMP_REG_C_ARG_1 8 +#define COMP_REG_C_ARG_2 9 +#define COMP_REG_C_ARG_3 10 +#define COMP_REG_C_ARG_4 11 +#define COMP_REG_MEMTOP 18 +#define COMP_REG_FREE 19 +#define COMP_REG_SCHEME_TO_INTERFACE 20 +#define COMP_REG_DYNAMIC_LINK 21 +#define COMP_REG_TRAMP_INDEX 13 + +#define COMP_REG_CLOSURE_FREE 22 +#define COMP_REG_ADDRESS_MASK 25 +#define COMP_REG_REGISTERS 26 +#define COMP_REG_QUAD_MASK 27 +#define COMP_REG_CLOSURE_HOOK 28 + +#define COMP_REG_KERNEL_RESERVED_1 2 +#define COMP_REG_KERNEL_RESERVED_2 3 +#define COMP_REG_KERNEL_RESERVED_3 4 +#define COMP_REG_C_GLOBALS +#define COMP_REG_C_STACK 30 +#define COMP_REG_LINKAGE 31 + +/* Interrupt/GC polling. */ + +/* Skip over this many BYTES to bypass the GC check code (ordinary +procedures and continuations differ from closures) */ + +#define ENTRY_SKIPPED_CHECK_OFFSET 12 +#define CLOSURE_SKIPPED_CHECK_OFFSET 40 + +/* The length of the GC recovery code that precedes an entry. + On the SPARC a "addi, jalr, addi" instruction sequence. + */ + +#define ENTRY_PREFIX_LENGTH 12 + +/* + The instructions for a normal entry should be something like + + ADDICC $at,$FREE,$MEMTOP + BGE interrupt + LD $MEMTOP,REG_BLOCK + + For a closure + + LUI $at,FROB(TC_CLOSURE) ; temp <- closure tag + XOR $1,$1,$at ; 1 <- tagged value + ADDI $SP,$SP,-4 ; push closure + ST $1,0($SP) + ADDICC $at,$FREE,$MEMTOP + BGE interrupt + LD $MEMTOP,REG_BLOCK +*/ + +/* A NOP on machines where instructions are longword-aligned. */ + +#define ADJUST_CLOSURE_AT_CALL(entry_point, location) \ +do { \ +} while (0) + +/* Compiled closures */ + +/* Manifest closure entry block size. + Size in bytes of a compiled closure's header excluding the + TC_MANIFEST_CLOSURE header. + + On the SPARC this is 2 format_words for the format word and gc offset + words, and 12 more bytes for 3 instructions. + + The three instructions are: + + SETHI %HI(TARGET), GLOBAL_TEMP + JMPL [GLOBAL_TEMP + %LO(TARGET)], GLOBAL_TEMP + ADDI 8,GLOBAL_TEMP,GLOBAL_TEMP + */ + +#define SETHI_GLOBAL_TEMP_TEMPLATE 0x03000000 +#define NOP_INSTRUCTION 0x01000000 +#define JMPL_TEMPLATE 0x81c06000 +#define CLOSURE_JMPL_TEMPLATE 0x83c06000 + +#define COMPILED_CLOSURE_ENTRY_SIZE 16 + +/* Manifest closure entry destructuring. + + Given the entry point of a closure, extract the `real entry point' + (the address of the real code of the procedure, ie. one indirection) + from the closure. + + On the SPARC we have to extract from a SETHI/JMPL_OFFSET sequence. + +*/ + +#define EXTRACT_CLOSURE_ENTRY_ADDRESS(extracted_ep, clos_addr) do \ +{ \ + unsigned long * addr = ((unsigned long*)(clos_addr)); \ + unsigned long sethi_instr = addr[0]; \ + unsigned long jmpl_instr = addr[1]; \ + (extracted_ep) = \ + ((SCHEME_OBJECT) \ + (((sethi_instr & 0x3fffff) << 10) | (jmpl_instr & 0x3ff))); \ +} while (0) + +/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS. + Given a closure's entry point and a code entry point, store the + code entry point in the closure. + */ + +/* The following is a SPARC ADDI 8,G1,G1 */ +#define CLOSURE_BUMP_LINKAGE_TO_DATA_INSTR 0x82006008 + +#define STORE_CLOSURE_ENTRY_ADDRESS(ep_to_store, clos_addr) do \ +{ \ + unsigned long * addr = (unsigned long *)(clos_addr); \ + unsigned long target = (unsigned long)(ep_to_store); \ + addr[0] = (addr[0] & SETHI_GLOBAL_TEMP_TEMPLATE) | (target >> 10); \ + addr[1] = (addr[1] & CLOSURE_JMPL_TEMPLATE) | (target & 0x000003ff); \ + addr[2] = CLOSURE_BUMP_LINKAGE_TO_DATA_INSTR; \ +} while (0) + +/* Trampolines + + On the SPARC, here's a picture of a trampoline (offset in bytes from + entry point) + + -12: MANIFEST vector header + - 8: NON_MARKED header + - 4: Format word + - 2: 0x6 (GC Offset to start of block from .+2) + Note the encoding -- divided by 2, low bit for + extended distances (see OFFSET_WORD_TO_BYTE_OFFSET) + 0: ADDI TEMP,SCHEME_TO_INTERFACE,MAGIC_CONSTANT + 4: JALR LINKAGE,TEMP + 8: ADDI TRAMP_INDEX,0,index + 12: trampoline dependent storage (0 - 3 longwords) + + TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine + dependent portion of a trampoline, including the GC and format + headers. The code in the trampoline must store an index (used to + determine which C SCHEME_UTILITY procedure to invoke) in a + register, jump to "scheme_to_interface" and leave the address of + the storage following the code in a standard location. + + TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a + trampoline when given the address of the word containing + the manifest vector header. According to the above picture, + it would add 12 bytes to its argument. + + TRAMPOLINE_STORAGE takes the address of the first instruction in a + trampoline (not the start of the trampoline block) and returns the + address of the first storage word in the trampoline. + + STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in + the trampoline and stores the instructions. It also receives the + index of the C SCHEME_UTILITY to be invoked. +*/ + +#define TRAMPOLINE_ENTRY_SIZE 5 +#define TRAMPOLINE_BLOCK_TO_ENTRY 3 + +#define TRAMPOLINE_ENTRY_POINT(tramp_block) \ + (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY) + +#define TRAMPOLINE_STORAGE(tramp_entry) \ + ((((SCHEME_OBJECT *)(tramp_entry)) + 3)) + +#define SPECIAL_OPCODE 000 +#define ADDI_OPCODE 010 + +#define OP(OPCODE) (OPCODE << 18) +#define SPECIAL_OP OP(SPECIAL_OPCODE) +#define ADDI_OP OP(ADDI_OPCODE) + +#define JALR_TEMPLATE 0x81c02000 +#define JALR_SRC(n) ((n & 0x1F) << 14) +#define JALR_DST(n) ((n & 0x1F) << 25) +#define JALR(d,s) (JALR_TEMPLATE|JALR_SRC(s)|JALR_DST(d)) + +#define ADDI_TEMPLATE 0x80002000 +#define ADDI_SRC(n) ((n & 0x1F) << 14) +#define ADDI_DST(n) ((n & 0x1F) << 25) +#define ADDI_IMMED(n) (n & 0x1FFF) +#define ADDI(d,s,imm) (ADDI_TEMPLATE|ADDI_DST(d)|ADDI_SRC(s)|ADDI_IMMED(imm)) + +#define STORE_TRAMPOLINE_ENTRY(entry_address, index) \ +{ unsigned long *PC; \ + PC = ((unsigned long *) (entry_address)); \ + *PC++ = ADDI(COMP_REG_TEMPORARY, COMP_REG_SCHEME_TO_INTERFACE, -8); \ + *PC++ = JALR(COMP_REG_C_ARG_1, COMP_REG_TEMPORARY); \ + *PC = ADDI(COMP_REG_TRAMP_INDEX, 0, (4*index)); \ + /* assumes index fits in 13 bits */ \ +} + +/* Execute cache entries. + + Execute cache entry size size in longwords. The cache itself + contains both the number of arguments provided by the caller and + code to jump to the destination address. Before linkage, the cache + contains the callee's name instead of the jump code. + + On SPARC: 3 instructions, the last being a NO-OP (SETHI with + constant 0, destination 0) + */ + +#define EXECUTE_CACHE_ENTRY_SIZE 3 + +/* Execute cache destructuring. */ + +/* Given a target location and the address of the first word of an + execute cache entry, extract from the cache cell the number of + arguments supplied by the caller and store it in target. */ + +/* For the SPARC (big endian), addresses in bytes from the start of + the cache: + + Before linking + +0: TC_SYMBOL || symbol address + +4: TC_FIXNUM || 0 + +6: number of supplied arguments, +1 + +8: ??? + + After linking + +0: SETHI global_temp (top 22 bits) + +4: JMPL global_temp (low 10 bits) + +8: NOP + +*/ + +#define SPARC_CACHE_ARITY_OFFSET 5 +#define SPARC_CACHE_CODE_OFFSET 8 + + +#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) \ +{ \ + (target) = \ + ((long) \ + (((unsigned short *) (address)) [SPARC_CACHE_ARITY_OFFSET]) & 0x0fff);\ +} + +#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) \ +{ \ + (target) = (* (((SCHEME_OBJECT *) (address)))); \ +} + +/* Extract the target address (not the code to get there) from an + execute cache cell. + */ + +#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) \ +{ \ + unsigned long * addr = ((unsigned long*)(address)); \ + unsigned long sethi_instr = addr[0]; \ + unsigned long jmpl_instr = addr[1]; \ + (target) = \ + ((SCHEME_OBJECT) \ + (((sethi_instr & 0x3fffff) << 10) | (jmpl_instr & 0x3ff))); \ +} + +/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS. + On the SPARC it must flush the I-cache, but there is no + need to flush the following ADDI instruction, which is a NOP. + */ + +#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) \ +{ \ + unsigned long * addr = (unsigned long *)(address); \ + unsigned long target = (unsigned long)(entry); \ + addr[0] = (addr[0] & SETHI_GLOBAL_TEMP_TEMPLATE) | (target >> 10); \ + addr[1] = (addr[1] & JMPL_TEMPLATE) | (target & 0x000003ff); \ +} + +/* This stores the fixed part of the instructions leaving the + destination address and the number of arguments intact. These are + split apart so the GC can call EXTRACT/STORE...ADDRESS but it does + NOT need to store the instructions back. On some architectures the + instructions may change due to GC and then STORE_EXECUTE_CACHE_CODE + should become a no-op and all of the work is done by + STORE_EXECUTE_CACHE_ADDRESS instead. + */ + + +#define STORE_EXECUTE_CACHE_CODE(address) \ +{ \ + unsigned long* nop_addr = (((unsigned long *)(address)) + 2); \ + unsigned long nop_val; \ + *((unsigned long *)address) = (SETHI_GLOBAL_TEMP_TEMPLATE); \ + *(((unsigned long *)(address))+1) = JMPL_TEMPLATE; \ + nop_val = (*nop_addr); \ + (*nop_addr) = ADDI(0,0,nop_val); \ +} + +/* This flushes the Scheme portion of the I-cache. + It is used after a GC or disk-restore. + It's needed because the GC has moved code around, and closures + and execute cache cells have absolute addresses that the + processor might have old copies of. + */ + +#define FLUSH_I_CACHE() do \ +{ \ + ICACHEFLUSH (Heap_Bottom, \ + ((sizeof(SCHEME_OBJECT)) * \ + (Heap_Top - Heap_Bottom))); \ + ICACHEFLUSH (Constant_Space, \ + ((sizeof(SCHEME_OBJECT)) * \ + (Constant_Top - Constant_Space))); \ + ICACHEFLUSH (Stack_Pointer, \ + ((sizeof(SCHEME_OBJECT)) * \ + (Stack_Top - Stack_Pointer))); \ +} while (0) + + +/* This flushes a region of the I-cache. + It is used after updating an execute cache while running. + Not needed during GC because FLUSH_I_CACHE will be used. + */ + +#define FLUSH_I_CACHE_REGION(address, nwords) do \ +{ \ + ICACHEFLUSH ((address), ((sizeof (long)) * (nwords))); \ +} while (0) + +#define PUSH_D_CACHE_REGION FLUSH_I_CACHE_REGION + +/* The following is misnamed. + It should really be called STORE_BACK_D_CACHE. + Neither the R2000 nor the R3000 systems have them. + I don't know about the R4000 or R6000. + */ + +/* #define SPLIT_CACHES */ + +#ifdef IN_CMPINT_C + + +#define CLOSURE_ENTRY_WORDS \ + (COMPILED_CLOSURE_ENTRY_SIZE / (sizeof (SCHEME_OBJECT))) + +static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS); + +#define REGBLOCK_CLOSURE_LIMIT REGBLOCK_CLOSURE_SPACE + +/* The apparently random instances of the number 3 below arise from + the convention that free_closure always points to a JAL instruction + with (at least) 3 unused words preceding it. + In this way, if there is enough space, we can use free_closure + as the address of a new uni- or multi-closure. + + The code below (in the initialization loop) depends on knowing that + CLOSURE_ENTRY_WORDS is 3. + + Random hack: ADDI instructions look like TC_TRUE objects, thus of the + pre-initialized words, only the JALR looks like a pointer object + (an SCODE-QUOTE). Since there is exactly one JALR of waste between + closures, and it is always 3 words before free_closure, + the code for uni-closure allocation (in mips.m4) bashes that word + with 0 (SHARP_F) to make the heap parseable. + */ + +/* size in Scheme objects of the block we need to allocate. */ + +void +DEFUN (allocate_closure, (size), long size) +{ + long space; + SCHEME_OBJECT * free_closure, * limit; + + free_closure = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_FREE]); + limit = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_LIMIT]); + space = ((limit - free_closure) + 3); + + /* Bump up to a multiple of CLOSURE_ENTRY_WORDS. + Otherwise clearing by the allocation code may clobber + a different word. + */ + size = (CLOSURE_ENTRY_WORDS + * ((size + (CLOSURE_ENTRY_WORDS - 1)) + / CLOSURE_ENTRY_WORDS)); + if (size > space) + { + long chunk_size; + SCHEME_OBJECT *ptr; + + /* Make the heap be parseable forward by protecting the waste + in the last chunk. + */ + + if ((space > 0) && (free_closure != ((SCHEME_OBJECT) NULL))) + free_closure[-3] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (space - 1))); + + free_closure = Free; + if ((size <= closure_chunk) && (!(GC_Check (closure_chunk)))) + limit = (free_closure + closure_chunk); + else + { + if (GC_Check (size)) + { + if ((Heap_Top - Free) < size) + { + /* No way to back out -- die. */ + fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size); + Microcode_Termination (TERM_NO_SPACE); + /* NOTREACHED */ + } + Request_GC (0); + } + else if (size <= closure_chunk) + Request_GC (0); + limit = (free_closure + size); + } + Free = limit; + chunk_size = (limit - free_closure); + + ptr = free_closure; + while (ptr < limit) + { + *ptr++ = (JALR (COMP_REG_LINKAGE, COMP_REG_CLOSURE_HOOK)); + *ptr++ = (ADDI (COMP_REG_LINKAGE, COMP_REG_LINKAGE, -8)); + *ptr++ = SHARP_F; + } + PUSH_D_CACHE_REGION (free_closure, chunk_size); + Registers[REGBLOCK_CLOSURE_LIMIT] = ((SCHEME_OBJECT) limit); + Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) (free_closure + 3)); + } + return; +} + +#endif /* IN_CMPINT_C */ + +/* Derived parameters and macros. + + These macros expect the above definitions to be meaningful. + If they are not, the macros below may have to be changed as well. + */ + +#define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1]) +#define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2]) + +/* The next one assumes 2's complement integers....*/ +#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) +#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) + +#if (PC_ZERO_BITS == 0) +/* Instructions aligned on byte boundaries */ +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + ((CLEAR_LOW_BIT(offset_word)) >> 1) +#endif + +#if (PC_ZERO_BITS == 1) +/* Instructions aligned on word (16 bit) boundaries */ +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + (CLEAR_LOW_BIT(offset_word)) +#endif + +#if (PC_ZERO_BITS >= 2) +/* Should be OK for =2, but bets are off for >2 because of problems + mentioned earlier! +*/ +#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) +#endif + +#define MAKE_OFFSET_WORD(entry, block, continue) \ + ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ + ((char *) (block)))) | \ + ((continue) ? 1 : 0)) + +#if (EXECUTE_CACHE_ENTRY_SIZE == 2) +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) >> 1) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) << 1) +#endif + +#if (EXECUTE_CACHE_ENTRY_SIZE == 4) +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) >> 2) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) << 2) +#endif + +#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES)) +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) / EXECUTE_CACHE_ENTRY_SIZE) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) * EXECUTE_CACHE_ENTRY_SIZE) +#endif + +/* The first entry in a cc block is preceeded by 2 headers (block and nmv), + a format word and a gc offset word. See the early part of the + TRAMPOLINE picture, above. + */ + +#define CC_BLOCK_FIRST_ENTRY_OFFSET \ + (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word)))) + +/* Format words */ + +#define FORMAT_BYTE_EXPR 0xFF +#define FORMAT_BYTE_COMPLR 0xFE +#define FORMAT_BYTE_CMPINT 0xFD +#define FORMAT_BYTE_DLINK 0xFC +#define FORMAT_BYTE_RETURN 0xFB + +#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR)) +#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT)) +#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN)) + +/* This assumes that a format word is at least 16 bits, + and the low order field is always 8 bits. + */ + +#define MAKE_FORMAT_WORD(field1, field2) \ + (((field1) << 8) | ((field2) & 0xff)) + +#define SIGN_EXTEND_FIELD(field, size) \ + (((field) & ((1 << (size)) - 1)) | \ + ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \ + ((-1) << (size)))) + +#define FORMAT_WORD_LOW_BYTE(word) \ + (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8)) + +#define FORMAT_WORD_HIGH_BYTE(word) \ + (SIGN_EXTEND_FIELD \ + ((((unsigned long) (word)) >> 8), \ + (((sizeof (format_word)) * CHAR_BIT) - 8))) + +#define COMPILED_ENTRY_FORMAT_HIGH(addr) \ + (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr))) + +#define COMPILED_ENTRY_FORMAT_LOW(addr) \ + (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr))) + +#define FORMAT_BYTE_FRAMEMAX 0x7f + +#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW +#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH + +#endif /* CMPINT2_H_INCLUDED */ diff --git a/v7/src/compiler/machines/sparc/coerce.scm b/v7/src/compiler/machines/sparc/coerce.scm new file mode 100644 index 000000000..447878493 --- /dev/null +++ b/v7/src/compiler/machines/sparc/coerce.scm @@ -0,0 +1,72 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/coerce.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ +$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $ + +Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +(declare (usual-integrations)) + +;;;; SPARC coercions + +;;; Coercion top level + +(define make-coercion + (coercion-maker + `((UNSIGNED . ,coerce-unsigned-integer) + (SIGNED . ,coerce-signed-integer)))) + +(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1)) +(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2)) +(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3)) +(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4)) +(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5)) +(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6)) +(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8)) +(define coerce-9-bit-unsigned (make-coercion 'UNSIGNED 9)) +(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10)) +(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11)) +(define coerce-13-bit-unsigned (make-coercion 'UNSIGNED 13)) +(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15)) +(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16)) +(define coerce-20-bit-unsigned (make-coercion 'UNSIGNED 20)) +(define coerce-22-bit-unsigned (make-coercion 'UNSIGNED 22)) +(define coerce-25-bit-unsigned (make-coercion 'UNSIGNED 25)) +(define coerce-26-bit-unsigned (make-coercion 'UNSIGNED 26)) +(define coerce-30-bit-unsigned (make-coercion 'UNSIGNED 30)) +(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32)) + +(define coerce-16-bit-signed (make-coercion 'SIGNED 16)) +(define coerce-13-bit-signed (make-coercion 'SIGNED 13)) +(define coerce-22-bit-signed (make-coercion 'SIGNED 22)) +(define coerce-26-bit-signed (make-coercion 'SIGNED 26)) +(define coerce-30-bit-signed (make-coercion 'SIGNED 30)) +(define coerce-32-bit-signed (make-coercion 'SIGNED 32)) diff --git a/v7/src/compiler/machines/sparc/decls.scm b/v7/src/compiler/machines/sparc/decls.scm new file mode 100644 index 000000000..457a97f86 --- /dev/null +++ b/v7/src/compiler/machines/sparc/decls.scm @@ -0,0 +1,627 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/decls.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ +$MC68020-Header: decls.scm,v 4.27 90/05/03 15:17:08 GMT jinx Exp $ + +Copyright (c) 1988-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler File Dependencies + +(declare (usual-integrations)) + +(define (initialize-package!) + (add-event-receiver! event:after-restore reset-source-nodes!) + (reset-source-nodes!)) + +(define (reset-source-nodes!) + (set! source-filenames '()) + (set! source-hash) + (set! source-nodes) + (set! source-nodes/by-rank)) + +(define (maybe-setup-source-nodes!) + (if (null? source-filenames) + (setup-source-nodes!))) + +(define (setup-source-nodes!) + (let ((filenames + (mapcan (lambda (subdirectory) + (map (lambda (pathname) + (string-append subdirectory + "/" + (pathname-name pathname))) + (directory-read + (string-append subdirectory + "/" + source-file-expression)))) + '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt" + "machines/sparc")))) + (if (null? filenames) + (error "Can't find source files of compiler")) + (set! source-filenames filenames)) + (set! source-hash + (make/hash-table + 101 + string-hash-mod + (lambda (filename source-node) + (string=? filename (source-node/filename source-node))) + make/source-node)) + (set! source-nodes + (map (lambda (filename) + (hash-table/intern! source-hash + filename + identity-procedure + identity-procedure)) + source-filenames)) + (initialize/syntax-dependencies!) + (initialize/integration-dependencies!) + (initialize/expansion-dependencies!) + (source-nodes/rank!)) + +(define source-file-expression "*.scm") +(define source-filenames) +(define source-hash) +(define source-nodes) +(define source-nodes/by-rank) + +(define (filename/append directory . names) + (map (lambda (name) (string-append directory "/" name)) names)) + +(define-structure (source-node + (conc-name source-node/) + (constructor make/source-node (filename))) + (filename false read-only true) + (pathname (string->pathname filename) read-only true) + (forward-links '()) + (backward-links '()) + (forward-closure '()) + (backward-closure '()) + (dependencies '()) + (dependents '()) + (rank false) + (syntax-table false) + (declarations '()) + (modification-time false)) + +(define (filename->source-node filename) + (hash-table/lookup source-hash + filename + identity-procedure + (lambda () (error "Unknown source file" filename)))) + +(define (source-node/circular? node) + (memq node (source-node/backward-closure node))) + +(define (source-node/link! node dependency) + (if (not (memq dependency (source-node/backward-links node))) + (begin + (set-source-node/backward-links! + node + (cons dependency (source-node/backward-links node))) + (set-source-node/forward-links! + dependency + (cons node (source-node/forward-links dependency))) + (source-node/close! node dependency)))) + +(define (source-node/close! node dependency) + (if (not (memq dependency (source-node/backward-closure node))) + (begin + (set-source-node/backward-closure! + node + (cons dependency (source-node/backward-closure node))) + (set-source-node/forward-closure! + dependency + (cons node (source-node/forward-closure dependency))) + (for-each (lambda (dependency) + (source-node/close! node dependency)) + (source-node/backward-closure dependency)) + (for-each (lambda (node) + (source-node/close! node dependency)) + (source-node/forward-closure node))))) + +;;;; Rank + +(define (source-nodes/rank!) + (compute-dependencies! source-nodes) + (compute-ranks! source-nodes) + (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))) + +(define (compute-dependencies! nodes) + (for-each (lambda (node) + (set-source-node/dependencies! + node + (list-transform-negative (source-node/backward-closure node) + (lambda (node*) + (memq node (source-node/backward-closure node*))))) + (set-source-node/dependents! + node + (list-transform-negative (source-node/forward-closure node) + (lambda (node*) + (memq node (source-node/forward-closure node*)))))) + nodes)) + +(define (compute-ranks! nodes) + (let loop ((nodes nodes) (unranked-nodes '())) + (if (null? nodes) + (if (not (null? unranked-nodes)) + (loop unranked-nodes '())) + (loop (cdr nodes) + (let ((node (car nodes))) + (let ((rank (source-node/rank* node))) + (if rank + (begin + (set-source-node/rank! node rank) + unranked-nodes) + (cons node unranked-nodes)))))))) + +(define (source-node/rank* node) + (let loop ((nodes (source-node/dependencies node)) (rank -1)) + (if (null? nodes) + (1+ rank) + (let ((rank* (source-node/rank (car nodes)))) + (and rank* + (loop (cdr nodes) (max rank rank*))))))) + +(define (source-nodes/sort-by-rank nodes) + (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y))))) + +;;;; File Syntaxer + +(define (syntax-files!) + (maybe-setup-source-nodes!) + (for-each + (lambda (node) + (let ((modification-time + (let ((source (modification-time node "scm")) + (binary (modification-time node "bin"))) + (if (not source) + (error "Missing source file" (source-node/filename node))) + (and binary (< source binary) binary)))) + (set-source-node/modification-time! node modification-time) + (if (not modification-time) + (begin (write-string "\nSource file newer than binary: ") + (write (source-node/filename node)))))) + source-nodes) + (if compiler:enable-integration-declarations? + (begin + (for-each + (lambda (node) + (let ((time (source-node/modification-time node))) + (if (and time + (there-exists? (source-node/dependencies node) + (lambda (node*) + (let ((newer? + (let ((time* + (source-node/modification-time node*))) + (or (not time*) + (> time* time))))) + (if newer? + (begin + (write-string "\nBinary file ") + (write (source-node/filename node)) + (write-string " newer than dependency ") + (write (source-node/filename node*)))) + newer?)))) + (set-source-node/modification-time! node false)))) + source-nodes) + (for-each + (lambda (node) + (if (not (source-node/modification-time node)) + (for-each (lambda (node*) + (if (source-node/modification-time node*) + (begin + (write-string "\nBinary file ") + (write (source-node/filename node*)) + (write-string " depends on ") + (write (source-node/filename node)))) + (set-source-node/modification-time! node* false)) + (source-node/forward-closure node)))) + source-nodes))) + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (pathname-delete! + (pathname-new-type (source-node/pathname node) "ext")))) + source-nodes/by-rank) + (write-string "\n\nBegin pass 1:") + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (source-node/syntax! node))) + source-nodes/by-rank) + (if (there-exists? source-nodes/by-rank + (lambda (node) + (and (not (source-node/modification-time node)) + (source-node/circular? node)))) + (begin + (write-string "\n\nBegin pass 2:") + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (if (source-node/circular? node) + (source-node/syntax! node) + (source-node/touch! node)))) + source-nodes/by-rank)))) + +(define (source-node/touch! node) + (with-values + (lambda () + (sf/pathname-defaulting (source-node/pathname node) "" false)) + (lambda (input-pathname bin-pathname spec-pathname) + input-pathname + (pathname-touch! bin-pathname) + (pathname-touch! (pathname-new-type bin-pathname "ext")) + (if spec-pathname (pathname-touch! spec-pathname))))) + +(define (pathname-touch! pathname) + (if (file-exists? pathname) + (begin + (write-string "\nTouch file: ") + (write (pathname->string pathname)) + (file-touch pathname)))) + +(define (pathname-delete! pathname) + (if (file-exists? pathname) + (begin + (write-string "\nDelete file: ") + (write (pathname->string pathname)) + (delete-file pathname)))) + +(define (sc filename) + (maybe-setup-source-nodes!) + (source-node/syntax! (filename->source-node filename))) + +(define (source-node/syntax! node) + (with-values + (lambda () + (sf/pathname-defaulting (source-node/pathname node) "" false)) + (lambda (input-pathname bin-pathname spec-pathname) + (sf/internal + input-pathname bin-pathname spec-pathname + (source-node/syntax-table node) + ((if compiler:enable-integration-declarations? + identity-procedure + (lambda (declarations) + (list-transform-negative declarations + integration-declaration?))) + ((if compiler:enable-expansion-declarations? + identity-procedure + (lambda (declarations) + (list-transform-negative declarations + expansion-declaration?))) + (source-node/declarations node))))))) + +(define-integrable (modification-time node type) + (file-modification-time + (pathname-new-type (source-node/pathname node) type))) + +;;;; Syntax dependencies + +(define (initialize/syntax-dependencies!) + (let ((file-dependency/syntax/join + (lambda (filenames syntax-table) + (for-each (lambda (filename) + (set-source-node/syntax-table! + (filename->source-node filename) + syntax-table)) + filenames)))) + (file-dependency/syntax/join + (append (filename/append "base" + "blocks" "cfg1" "cfg2" "cfg3" "constr" + "contin" "crstop" "ctypes" "debug" "enumer" + "infnew" "lvalue" "object" "pmerly" "proced" + "refctx" "rvalue" "scode" "sets" "subprb" + "switch" "toplev" "utils") + (filename/append "back" + "asmmac" "bittop" "bitutl" "insseq" "lapgn1" + "lapgn2" "lapgn3" "linear" "regmap" "symtab" + "syntax") + (filename/append "machines/sparc" + "insmac" "lapopt" "machin" "rulrew" "rgspcm") + (filename/append "fggen" + "declar" "fggen" "canon") + (filename/append "fgopt" + "blktyp" "closan" "conect" "contan" "delint" + "desenv" "envopt" "folcon" "offset" "operan" + "order" "outer" "param" "reord" "reteqv" "reuse" + "sideff" "simapp" "simple" "subfre" "varind") + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" + "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2" + "valclass") + (filename/append "rtlgen" + "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" + "rgretn" "rgrval" "rgstmt" "rtlgen") + (filename/append "rtlopt" + "ralloc" "rcompr" "rcse1" "rcse2" "rcseep" + "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow" + "rerite" "rinvex" "rlife" "rtlcsm")) + compiler-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/sparc" + "lapgen" + "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo") + lap-generator-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/sparc" + "instr1" "instr2a" "instr2b" "instr3") + assembler-syntax-table))) + +;;;; Integration Dependencies + +(define (initialize/integration-dependencies!) + + (define (add-declaration! declaration filenames) + (for-each (lambda (filenames) + (let ((node (filename->source-node filenames))) + (set-source-node/declarations! + node + (cons declaration + (source-node/declarations node))))) + filenames)) + + (let* ((front-end-base + (filename/append "base" + "blocks" "cfg1" "cfg2" "cfg3" + "contin" "ctypes" "enumer" "lvalue" + "object" "proced" "rvalue" + "scode" "subprb" "utils")) + (sparc-base + (filename/append "machines/sparc" "machin")) + (rtl-base + (filename/append "rtlbase" + "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1" + "rtlty2")) + (cse-base + (filename/append "rtlopt" + "rcse1" "rcseht" "rcserq" "rcsesr")) + (cse-all + (append (filename/append "rtlopt" + "rcse2" "rcseep") + cse-base)) + (instruction-base + (filename/append "machines/sparc" "assmd" "machin")) + (lapgen-base + (append (filename/append "back" "lapgn3" "regmap") + (filename/append "machines/sparc" "lapgen"))) + (assembler-base + (append (filename/append "back" "symtab") + (filename/append "machines/sparc" "instr1"))) + (lapgen-body + (append + (filename/append "back" "lapgn1" "lapgn2" "syntax") + (filename/append "machines/sparc" + "rules1" "rules2" "rules3" "rules4" + "rulfix" "rulflo"))) + (assembler-body + (append + (filename/append "back" "bittop") + (filename/append "machines/sparc" + "instr1" "instr2a" "instr2b" "instr3")))) + + (define (file-dependency/integration/join filenames dependencies) + (for-each (lambda (filename) + (file-dependency/integration/make filename dependencies)) + filenames)) + + (define (file-dependency/integration/make filename dependencies) + (let ((node (filename->source-node filename))) + (for-each (lambda (dependency) + (let ((node* (filename->source-node dependency))) + (if (not (eq? node node*)) + (source-node/link! node node*)))) + dependencies))) + + (define (define-integration-dependencies directory name directory* . names) + (file-dependency/integration/make + (string-append directory "/" name) + (apply filename/append directory* names))) + + (define-integration-dependencies "base" "object" "base" "enumer") + (define-integration-dependencies "base" "enumer" "base" "object") + (define-integration-dependencies "base" "utils" "base" "scode") + (define-integration-dependencies "base" "cfg1" "base" "object") + (define-integration-dependencies "base" "cfg2" "base" + "cfg1" "cfg3" "object") + (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2") + (define-integration-dependencies "base" "ctypes" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb") + (define-integration-dependencies "base" "rvalue" "base" + "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils") + (define-integration-dependencies "base" "lvalue" "base" + "blocks" "object" "proced" "rvalue" "utils") + (define-integration-dependencies "base" "blocks" "base" + "enumer" "lvalue" "object" "proced" "rvalue" "scode") + (define-integration-dependencies "base" "proced" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object" + "rvalue" "utils") + (define-integration-dependencies "base" "contin" "base" + "blocks" "cfg3" "ctypes") + (define-integration-dependencies "base" "subprb" "base" + "cfg3" "contin" "enumer" "object" "proced") + + (define-integration-dependencies "machines/sparc" "machin" "rtlbase" + "rtlreg" "rtlty1" "rtlty2") + + (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2") + (define-integration-dependencies "rtlbase" "rgraph" "machines/sparc" + "machin") + (define-integration-dependencies "rtlbase" "rtlcfg" "base" + "cfg1" "cfg2" "cfg3") + (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils") + (define-integration-dependencies "rtlbase" "rtlcon" "machines/sparc" + "machin") + (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" + "rtlreg" "rtlty1") + (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2") + (define-integration-dependencies "rtlbase" "rtline" "rtlbase" + "rtlcfg" "rtlty2") + (define-integration-dependencies "rtlbase" "rtlobj" "base" + "cfg1" "object" "utils") + (define-integration-dependencies "rtlbase" "rtlreg" "machines/sparc" + "machin") + (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase" + "rgraph" "rtlty1") + (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg") + (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode") + (define-integration-dependencies "rtlbase" "rtlty2" "machines/sparc" + "machin") + (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1") + + (file-dependency/integration/join + (append + (filename/append "base" "refctx") + (filename/append "fggen" + "declar" "fggen") ; "canon" needs no integrations + (filename/append "fgopt" + "blktyp" "closan" "conect" "contan" "delint" "desenv" + "envopt" "folcon" "offset" "operan" "order" "param" + "outer" "reuse" "reteqv" "sideff" "simapp" "simple" + "subfre" "varind")) + (append sparc-base front-end-base)) + + (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord") + + (file-dependency/integration/join + (filename/append "rtlgen" + "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn" + "rgrval" "rgstmt" "rtlgen") + (append sparc-base front-end-base rtl-base)) + + (file-dependency/integration/join + (append cse-all + (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow" + "rerite" "rinvex" "rlife" "rtlcsm") + (filename/append "machines/sparc" "rulrew")) + (append sparc-base rtl-base)) + + (file-dependency/integration/join cse-all cse-base) + + (file-dependency/integration/join + (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife") + (filename/append "rtlbase" "regset")) + + (file-dependency/integration/join + (filename/append "rtlopt" "rcseht" "rcserq") + (filename/append "base" "object")) + + (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2") + + (let ((dependents + (append instruction-base + lapgen-base + lapgen-body + assembler-base + assembler-body + (filename/append "back" "linear" "syerly")))) + (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents) + (file-dependency/integration/join dependents instruction-base)) + + (file-dependency/integration/join (append lapgen-base lapgen-body) + lapgen-base) + + (file-dependency/integration/join (append assembler-base assembler-body) + assembler-base) + + (define-integration-dependencies "back" "lapgn1" "base" + "cfg1" "cfg2" "utils") + (define-integration-dependencies "back" "lapgn1" "rtlbase" + "rgraph" "rtlcfg") + (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg") + (define-integration-dependencies "back" "lapgn3" "rtlbase" "rtlcfg") + (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2") + (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg") + (define-integration-dependencies "back" "mermap" "back" "regmap") + (define-integration-dependencies "back" "regmap" "base" "utils") + (define-integration-dependencies "back" "symtab" "base" "utils")) + + (for-each (lambda (node) + (let ((links (source-node/backward-links node))) + (if (not (null? links)) + (set-source-node/declarations! + node + (cons (make-integration-declaration + (source-node/pathname node) + (map source-node/pathname links)) + (source-node/declarations node)))))) + source-nodes)) + +(define (make-integration-declaration pathname integration-dependencies) + `(INTEGRATE-EXTERNAL + ,@(map (let ((default + (make-pathname + false + false + (make-list (length (pathname-directory pathname)) 'UP) + false + false + false))) + (lambda (pathname) + (merge-pathnames pathname default))) + integration-dependencies))) + +(define-integrable (integration-declaration? declaration) + (eq? (car declaration) 'INTEGRATE-EXTERNAL)) + +;;;; Expansion Dependencies + +(define (initialize/expansion-dependencies!) + (let ((file-dependency/expansion/join + (lambda (filenames expansions) + (for-each (lambda (filename) + (let ((node (filename->source-node filename))) + (set-source-node/declarations! + node + (cons (make-expansion-declaration expansions) + (source-node/declarations node))))) + filenames)))) + (file-dependency/expansion/join + (filename/append "machines/sparc" + "lapgen" "rules1" "rules2" "rules3" "rules4" + "rulfix" "rulflo") + (map (lambda (entry) + `(,(car entry) + (PACKAGE/REFERENCE (FIND-PACKAGE '(COMPILER LAP-SYNTAXER)) + ',(cadr entry)))) + '((LAP:SYNTAX-INSTRUCTION LAP:SYNTAX-INSTRUCTION-EXPANDER) + (INSTRUCTION->INSTRUCTION-SEQUENCE + INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER) + (SYNTAX-EVALUATION SYNTAX-EVALUATION-EXPANDER) + (CONS-SYNTAX CONS-SYNTAX-EXPANDER) + (OPTIMIZE-GROUP-EARLY OPTIMIZE-GROUP-EXPANDER) + (EA-KEYWORD-EARLY EA-KEYWORD-EXPANDER) + (EA-MODE-EARLY EA-MODE-EXPANDER) + (EA-REGISTER-EARLY EA-REGISTER-EXPANDER) + (EA-EXTENSION-EARLY EA-EXTENSION-EXPANDER) + (EA-CATEGORIES-EARLY EA-CATEGORIES-EXPANDER)))))) + +(define-integrable (make-expansion-declaration expansions) + `(EXPAND-OPERATOR ,@expansions)) + +(define-integrable (expansion-declaration? declaration) + (eq? (car declaration) 'EXPAND-OPERATOR)) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/inerly.scm b/v7/src/compiler/machines/sparc/inerly.scm new file mode 100644 index 000000000..b48cc569a --- /dev/null +++ b/v7/src/compiler/machines/sparc/inerly.scm @@ -0,0 +1,91 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/inerly.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ +$MC68020-Header: inerly.scm,v 1.6 88/08/31 06:00:59 GMT cph Exp $ + +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;; SPARC Instruction Set Macros. Early version +;;; NOPs for now. + +(declare (usual-integrations)) + +;;;; Transformers and utilities + +(define early-instructions '()) +(define early-transformers '()) + +(define (define-early-transformer name transformer) + (set! early-transformers + (cons (cons name transformer) + early-transformers))) + +(define (eq-subset? s1 s2) + (or (null? s1) + (and (memq (car s1) s2) + (eq-subset? (cdr s1) s2)))) + +;;; Instruction and addressing mode macros + +(syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION + (macro (opcode . patterns) + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode + ,@(map (lambda (pattern) + `(early-parse-rule + ',(car pattern) + (lambda (pat vars) + (early-make-rule + pat + vars + (scode-quote + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + true))))))) + patterns)) + EARLY-INSTRUCTIONS)))) + + + + + + + + + + + + + + + diff --git a/v7/src/compiler/machines/sparc/insmac.scm b/v7/src/compiler/machines/sparc/insmac.scm new file mode 100644 index 000000000..200ff0f41 --- /dev/null +++ b/v7/src/compiler/machines/sparc/insmac.scm @@ -0,0 +1,149 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/insmac.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1988-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SPARC Instruction Set Macros + +(declare (usual-integrations)) + +;;;; 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 (and (eq? endianness 'LITTLE) + (= 32 (+ word-size car-size))) + (expand '() 0 (cdr fields) + (lambda (tail tail-size) + (receiver + (append (cons car-field first-word) tail) + (+ car-size tail-size)))) + (expand (cons car-field first-word) + (+ car-size word-size) + (cdr fields) + (lambda (tail tail-size) + (receiver + (if (or (zero? car-size) + (not (eq? endianness 'LITTLE))) + (cons car-field tail) + tail) + (+ car-size tail-size))))))))) + (expand '() 0 fields receiver)) + +(define (expand-field field early? receiver) + early? ; ignored for now + (let ((size (car field)) + (expression (cadr field))) + + (define (default type) + (receiver (integer-syntaxer expression type size) + size)) + + (if (null? (cddr field)) + (default 'UNSIGNED) + (case (caddr field) + ((PC-REL) + (receiver + (integer-syntaxer ``(- ,,expression (+ *PC* 4)) + (cadddr field) + size) + size)) + ((BLOCK-OFFSET) + (receiver (list 'list ''BLOCK-OFFSET expression) + size)) + (else + (default (caddr field))))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/instr1.scm b/v7/src/compiler/machines/sparc/instr1.scm new file mode 100644 index 000000000..ddfea67e8 --- /dev/null +++ b/v7/src/compiler/machines/sparc/instr1.scm @@ -0,0 +1,273 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/instr1.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1987-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; MIPS instruction set + +;; Branch-tensioned instructions are in instr2.scm +;; Floating point instructions are in instr3.scm + +(declare (usual-integrations)) + +(let-syntax + ((arithmetic-immediate-instruction + (macro (keyword opcode) + `(define-instruction ,keyword + (((? destination) (? source) (? immediate)) + (VARIABLE-WIDTH (evaluated-immediate immediate) + ((#x-2000 #x1fff) + (LONG (2 2) + (5 destination) + (6 ,opcode) + (5 source) + (1 1) + (13 evaluated-immediate SIGNED))) + ((() ()) + ;; SETHI $1, top(immediate) + ;; OR $1, bottom(immediate) + ;; reg-op $destination, $source, $1 + (LONG (2 0) + (5 1) + (3 4) + (22 evaluated-immediate) ; SETHI + (2 2) + (5 1) + (6 2) + (5 1) + (1 1) + (13 evaluated-immediate SIGNED) ; OR + (2 0) + (5 destination) + (6 ,opcode) + (5 source) + (1 0) + (8 0) + (5 1))))))))) ; reg-op + (arithmetic-immediate-instruction addi 0) + (arithmetic-immediate-instruction addcci 16) + (arithmetic-immediate-instruction addxi 8) + (arithmetic-immediate-instruction addxcci 24) + (arithmetic-immediate-instruction andi 1) + (arithmetic-immediate-instruction andcci 17) + (arithmetic-immediate-instruction andni 5) + (arithmetic-immediate-instruction andncci 21) + (arithmetic-immediate-instruction ori 2) + (arithmetic-immediate-instruction orcci 18) + (arithmetic-immediate-instruction orni 6) + (arithmetic-immediate-instruction orncci 22) + (arithmetic-immediate-instruction xori 3) + (arithmetic-immediate-instruction xorcci 19) + (arithmetic-immediate-instruction xnori 7) + (arithmetic-immediate-instruction xnorcc 23) + (arithmetic-immediate-instruction subi 4) + (arithmetic-immediate-instruction subcci 20) + (arithmetic-immediate-instruction subxi 12) + (arithmetic-immediate-instruction subxcci 28) + (arithmetic-immediate-instruction umuli 10) + (arithmetic-immediate-instruction smuli 11) + (arithmetic-immediate-instruction umulcci 26) + (arithmetic-immediate-instruction smulcci 27) + (arithmetic-immediate-instruction udivi 14) + (arithmetic-immediate-instruction sdivi 15) + (arithmetic-immediate-instruction udivcci 30) + (arithmetic-immediate-instruction sdivcci 31) + ) + + +(define-instruction lui + (((? destination) (? immediate)) + (LONG (6 15) + (5 0) + (5 destination) + (16 immediate)))) + +(define-instruction li + (((? destination) (? immediate)) + (VARIABLE-WIDTH (evaluated-immediate immediate) + ((#x-2000 #x1fff) + (LONG (2 2) + (5 destination) + (6 2) + (5 0) + (1 1) + (13 evaluated-immediate SIGNED))) + ((() ()) + ;; SETHI $1, top(immediate) + ;; OR $1, bottom(immediate) + (LONG (2 0) + (5 1) + (3 4) + (22 (high-bits evaluated-immediate)) ; SETHI + (2 2) + (5 1) + (6 2) + (5 1) + (1 1) + (13 (low-bits evaluated-immediate) SIGNED) ; OR + ))))) + + +(let-syntax + ((3-operand-instruction + (macro (keyword opcode) + `(define-instruction ,keyword + (((? destination) (? source-1) (? source-2)) + (LONG (2 2) + (5 destination) + (6 ,opcode) + (5 source-1) + (1 0) + (8 0) + (5 source-2) + )))))) + (3-operand-instruction add 0) + (3-operand-instruction addcc 16) + (3-operand-instruction addx 8) + (3-operand-instruction addxcc 24) + (3-operand-instruction andr 1) + (3-operand-instruction andcc 17) + (3-operand-instruction andn 5) + (3-operand-instruction andncc 21) + (3-operand-instruction orr 2) + (3-operand-instruction orcc 18) + (3-operand-instruction orn 6) + (3-operand-instruction orncc 22) + (3-operand-instruction xorr 3) + (3-operand-instruction xorcc 19) + (3-operand-instruction xnor 7) + (3-operand-instruction xnorcc 23) + (3-operand-instruction sllv 37) + (3-operand-instruction srlv 38) + (3-operand-instruction srav 39) + (3-operand-instruction subr 4) + (3-operand-instruction subcc 20) + (3-operand-instruction subx 12) + (3-operand-instruction umul 10) + (3-operand-instruction smul 11) + (3-operand-instruction umulcc 26) + (3-operand-instruction smulcc 27) + (3-operand-instruction udiv 14) + (3-operand-instruction sdiv 15) + (3-operand-instruction udivcc 30) + (3-operand-instruction sdivcc 31) + ) + + +(let-syntax + ((shift-instruction-immediate + (macro (keyword opcode) + `(define-instruction ,keyword + (((? destination) (? source) (? amount)) + (LONG (2 2) + (5 destination) + (6 ,opcode) + (5 source) + (1 1) + (8 0) + (5 amount) + )))))) + (shift-instruction-immediate sll 37) + (shift-instruction-immediate srl 38) + (shift-instruction-immediate sra 39)) + + + +(define-instruction jalr + (((? destination) (? source)) + (LONG (2 2) + (5 destination) + (6 56) + (5 source) + (1 0) + (8 0) + (5 0)))) + +(define-instruction jr + (((? source)) + (LONG (2 2) + (5 0) + (6 56) + (5 source) + (1 0) + (8 0) + (5 0)))) + +(define-instruction jmpl + (((? destination) (? source1) (? source2)) + (LONG (2 2) + (5 destination) + (6 56) + (5 source1) + (1 0) + (8 0) + (5 source2)))) + +(define-instruction call + (((? offset)) + (LONG (2 1) + (30 (quotient offset 4) SIGNED)))) + +(define-instruction sethi + (((? destination) (? bits)) + (LONG (2 0) + (5 destination) + (3 4) + (22 (top-22-bits bits) UNSIGNED)))) + + +;;;; Assembler pseudo-ops + +(define-instruction EXTERNAL-LABEL + ;; External labels provide the garbage collector with header + ;; information and the runtime system with type, arity, and + ;; debugging information. + (((? format-word) (@PCR (? label))) + (if (eq? endianness 'LITTLE) + (LONG (16 label BLOCK-OFFSET) + (16 format-word UNSIGNED)) + (LONG (16 format-word UNSIGNED) + (16 label BLOCK-OFFSET))))) + +(define-instruction NOP + ;; SETHI $0, 0 + (() + (LONG (2 0) + (5 0) + (3 4) + (22 0)))) + +(define-instruction LONG + ((S (? value)) + (LONG (32 value SIGNED))) + ((U (? value)) + (LONG (32 value UNSIGNED)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/instr2a.scm b/v7/src/compiler/machines/sparc/instr2a.scm new file mode 100644 index 000000000..b0a13f6f1 --- /dev/null +++ b/v7/src/compiler/machines/sparc/instr2a.scm @@ -0,0 +1,114 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/instr2a.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1987-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SPARC instruction set, part 2a + +(declare (usual-integrations)) + +;;;; Instructions that require branch tensioning: branch + +(let-syntax + ((branch + (macro (keyword annul condition) + `(define-instruction ,keyword + (((@PCO (? offset))) + (LONG (2 0) + ,annul + ,condition + (3 2) + (22 (quotient offset 4) SIGNED))) + (((@PCR (? label))) + (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 0)) 4)) + ((#x-400000 #x3fffff) + (LONG (2 0) + ,annul + ,condition + (3 2) + (22 offset SIGNED))) + ((() ()) + ;; B??a condition, yyy + ;; JMPL xxx, $0 + ;; yyy: SETHI $1, high(offset) + ;; OR $1, $1, low(offset) + ;; JMPL $1,$0 + ;; xxx: fall through + (LONG (2 0) + (1 1) ; set anull bit, the JMPL is cancelled + ; on a taken branch + ,condition + (3 2) + (22 2 SIGNED) ; B??condition, yyy + (2 2) + (5 0) + (6 #x38) + (5 0) + (1 1) + (13 16 SIGNED) ; JMPL xxx, $0 + (2 0) + (5 1) + (3 4) + (22 (high-bits (* offset 4)) SIGNED) + ; SETHI $1, high22(offset) + (2 2) + (5 1) + (6 2) + (5 1) + (1 1) + (13 (low-bits (* offset 4)) SIGNED) + ; OR $1, $1, low10(offset) + (2 2) + (5 0) + (6 #x38) + (5 1) + (1 0) + (8 0) + (5 0) ; JMPL $1,$0 + )))))))) + (branch ba (1 0) (4 8)) + (branch bn (1 0) (4 0)) + (branch bne (1 0) (4 9)) + (branch be (1 0) (4 1)) + (branch bg (1 0) (4 10)) + (branch ble (1 0) (4 2)) + (branch bge (1 0) (4 11)) + (branch bl (1 0) (4 3)) + (branch bgu (1 0) (4 12)) + (branch bleu (1 0) (4 4)) + (branch bcc (1 0) (4 13)) + (branch bcs (1 0) (4 5)) + (branch bpos (1 0) (4 14)) + (branch bneg (1 0) (4 6)) + (branch bvc (1 0) (4 15)) + (branch bvs (1 0) (4 7)) + ) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/instr2b.scm b/v7/src/compiler/machines/sparc/instr2b.scm new file mode 100644 index 000000000..ed271bd3f --- /dev/null +++ b/v7/src/compiler/machines/sparc/instr2b.scm @@ -0,0 +1,93 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/instr2b.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1987-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SPARC instruction set, part 2b + +(declare (usual-integrations)) + +;;;; Instructions that require branch tensioning: load/store + +(let-syntax + ((load/store-instruction + (macro (keyword opcode) + `(define-instruction ,keyword + (((? source/dest-reg) (OFFSET (? offset-ls) (? base-reg))) + (VARIABLE-WIDTH (delta offset-ls) + ((#x-fff #xfff) + (LONG (2 3) + (5 source/dest-reg) + (6 ,opcode) + (5 base-reg) + (1 1) + (13 delta SIGNED))) + ((() ()) + ;; SETHI 1, %hi(offset) + ;; OR 1, 1, %lo(offset) + ;; LD source/dest-reg,1,base-reg + (LONG (2 0) ; SETHI + (5 1) + (3 4) + (22 (high-bits delta)) + + (2 2) ; OR + (5 1) + (6 2) + (5 1) + (1 1) + (13 (low-bits delta)) + + (2 3) ; LD + (5 source/dest-reg) + (6 ,opcode) + (5 1) + (1 0) + (8 0) + (5 base-reg))))))))) + (load/store-instruction ldsb 9) + (load/store-instruction ldsh 10) + (load/store-instruction ldub 1) + (load/store-instruction lduh 2) + (load/store-instruction ld 0) + (load/store-instruction ldd 3) + (load/store-instruction stb 5) + (load/store-instruction sth 6) + (load/store-instruction st 4) + (load/store-instruction std 7) + (load/store-instruction ldf 32) + (load/store-instruction lddf 35) + (load/store-instruction ldfsr 33) + (load/store-instruction stf 36) + (load/store-instruction ltdf 39) + (load/store-instruction stfsr 37) + ) diff --git a/v7/src/compiler/machines/sparc/instr3.scm b/v7/src/compiler/machines/sparc/instr3.scm new file mode 100644 index 000000000..bbe03e828 --- /dev/null +++ b/v7/src/compiler/machines/sparc/instr3.scm @@ -0,0 +1,120 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/instr3.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1987-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SPARC instruction set, part 3 + +(declare (usual-integrations)) + +(let-syntax + ((float-instruction-3 + (macro (keyword major minor) + `(define-instruction ,keyword + (((? destination) (? source1) (? source2)) + (LONG (2 2) + (5 destination) + (6 ,major) + (5 source1) + (9 ,minor) + (5 source2))))))) + (float-instruction-3 fadds 52 65) + (float-instruction-3 faddd 52 66) + (float-instruction-3 faddq 52 67) + (float-instruction-3 fsubs 52 69) + (float-instruction-3 fsubd 52 70) + (float-instruction-3 fsubq 52 71) + (float-instruction-3 fmuls 52 73) + (float-instruction-3 fmuld 52 74) + (float-instruction-3 fmulq 52 75) + (float-instruction-3 fsmuld 52 #x69) + (float-instruction-3 fdmulq 52 #x6e) + (float-instruction-3 fdivs 52 #x4d) + (float-instruction-3 fdivd 52 #x4e) + (float-instruction-3 fdivq 52 #x4f)) + +(let-syntax + ((float-instruction-cmp + (macro (keyword major minor) + `(define-instruction ,keyword + (((? source1) (? source2)) + (LONG (2 2) + (5 0) + (6 ,major) + (5 source1) + (9 ,minor) + (5 source2))))))) + (float-instruction-cmp fcmps 53 #x51) + (float-instruction-cmp fcmpd 53 #x52) + (float-instruction-cmp fcmpq 53 #x53) + (float-instruction-cmp fcmpes 53 #x55) + (float-instruction-cmp fcmped 53 #x56) + (float-instruction-cmp fcmpeq 53 #x57)) + +(let-syntax + ((float-instruction-2 + (macro (keyword major minor) + `(define-instruction ,keyword + (((? destination) (? source)) + (LONG (2 2) + (5 destination) + (6 ,major) + (5 0) + (9 ,minor) + (5 source))))))) + (float-instruction-2 fsqrts #x34 #x29) + (float-instruction-2 fsqrtd #x34 #x2a) + (float-instruction-2 fsqrtq #x34 #x2b) + + (float-instruction-2 fmovs #x34 #x01) + (float-instruction-2 fnegs #x34 #x05) + (float-instruction-2 fabss #x34 #x09) + + (float-instruction-2 fstoi #x34 #xd1) + (float-instruction-2 fdtoi #x34 #xd2) + (float-instruction-2 fqtoi #x34 #xd3) + + (float-instruction-2 fitos #x34 #xc4) + (float-instruction-2 fitod #x34 #xc8) + (float-instruction-2 fitoq #x34 #xcc) + + (float-instruction-2 fstod #x34 #xc9) + (float-instruction-2 fstoq #x34 #xcd) + + (float-instruction-2 fdtos #x34 #xc6) + (float-instruction-2 fstod #x34 #xce) + + (float-instruction-2 fstod #x34 #xc7) + (float-instruction-2 fstod #x34 #xcb)) + + + \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/lapgen.scm b/v7/src/compiler/machines/sparc/lapgen.scm new file mode 100644 index 000000000..891b013c1 --- /dev/null +++ b/v7/src/compiler/machines/sparc/lapgen.scm @@ -0,0 +1,688 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/lapgen.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1988-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Rules for SPARC. Shared utilities. +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Register-Allocator Interface + +(define (register->register-transfer source target) + (if (not (register-types-compatible? source target)) + (error "Moving between incompatible register types" source target)) + (case (register-type source) + ((GENERAL) (copy source target)) + ((FLOAT) (fp-copy source target)) + (else (error "unknown register type" source)))) + +(define (home->register-transfer source target) + (memory->register-transfer (pseudo-register-displacement source) + regnum:regs-pointer + target)) + +(define (register->home-transfer source target) + (register->memory-transfer source + (pseudo-register-displacement target) + regnum:regs-pointer)) + +(define (reference->register-transfer source target) + (case (ea/mode source) + ((GR) + (copy (register-ea/register source) target)) + ((FPR) + (fp-copy (fpr->float-register (register-ea/register source)) target)) + ((OFFSET) + (memory->register-transfer (offset-ea/offset source) + (offset-ea/register source) + target)) + (else + (error "unknown effective-address mode" source)))) + +(define (pseudo-register-home register) + ;; Register block consists of 16 4-byte registers followed by 256 + ;; 8-byte temporaries. + (INST-EA (OFFSET ,(pseudo-register-displacement register) + ,regnum:regs-pointer))) + +(define-integrable (sort-machine-registers registers) + registers) + +(define available-machine-registers + (list + ;; g0 g1 + g2 g3 g4 + ;; g5 g6 g7 + + g22 g23 ;; g24 + g28 g29 g30 + + g8 g9 g10 g11 g12 g13 + + ;; g14 g15 + ;; g16 g17 g18 g19 g20 g21 g22 + ;; g25 g26 g27 g28 + ;; g31 ; could be available if handled right + + fp0 fp2 fp4 fp6 fp8 fp10 fp12 fp14 + fp16 fp18 fp20 fp22 fp24 fp26 fp28 fp30 + ;; fp1 fp3 fp5 fp7 fp9 fp11 fp13 fp15 + ;; fp17 fp19 fp21 fp23 fp25 fp27 fp29 fp31 + )) + +(define-integrable (float-register? register) + (eq? (register-type register) 'FLOAT)) + +(define-integrable (general-register? register) + (eq? (register-type register) 'GENERAL)) + +(define-integrable (word-register? register) + (eq? (register-type register) 'GENERAL)) + +(define (register-types-compatible? type1 type2) + (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT))) + +(define (register-type register) + (cond ((machine-register? register) + (vector-ref + '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT) + register)) + ((register-value-class=word? register) 'GENERAL) + ((register-value-class=float? register) 'FLOAT) + (else (error "unable to determine register type" register)))) + +(define register-reference + (let ((references (make-vector number-of-machine-registers))) + (let loop ((register 0)) + (if (< register 32) + (begin + (vector-set! references register (INST-EA (GR ,register))) + (loop (1+ register))))) + (let loop ((register 32) (fpr 0)) + (if (< register 48) + (begin + (vector-set! references register (INST-EA (FPR ,fpr))) + (loop (1+ register) (1+ fpr))))) + (lambda (register) + (vector-ref references register)))) + +;;;; Useful Cliches + +(define (memory->register-transfer offset base target) + (case (register-type target) + ((GENERAL) (LAP (LD ,target (OFFSET ,offset ,base)) (NOP))) + ((FLOAT) (fp-load-doubleword offset base target #T)) + (else (error "unknown register type" target)))) + +(define (register->memory-transfer source offset base) + (case (register-type source) + ((GENERAL) (LAP (ST ,source (OFFSET ,offset ,base)))) + ((FLOAT) (fp-store-doubleword offset base source)) + (else (error "unknown register type" source)))) + +(define (load-constant target constant delay-slot? record?) + ;; Load a Scheme constant into a machine register. + (if (non-pointer-object? constant) + (load-immediate target (non-pointer->literal constant) record?) + (load-pc-relative target + 'CONSTANT + (constant->label constant) + delay-slot?))) + +(define (deposit-type-address type source target) + (deposit-type-datum (fix:xor (quotient #x10 type-scale-factor) type) + source + target)) + +(define (deposit-type-datum type source target) + (with-values + (lambda () + (immediate->register (make-non-pointer-literal type 0))) + (lambda (prefix alias) + (LAP ,@prefix + (XORR ,target ,alias ,source))))) + +(define (non-pointer->literal constant) + (make-non-pointer-literal (object-type constant) + (careful-object-datum constant))) + +(define-integrable (make-non-pointer-literal type datum) + (+ (* type (expt 2 scheme-datum-width)) datum)) + +(define-integrable (deposit-type type-num target-reg) + (if (= target-reg regnum:assembler-temp) + (error "deposit-type: into register 1")) + (LAP (ANDR ,target-reg ,target-reg ,regnum:address-mask) + ,@(put-type type-num target-reg))) + +(define-integrable (put-type type-num target-reg) + ; Assumes that target-reg has 0 in type bits + (LAP (SETHI ,regnum:assembler-temp ,(* type-num #x4000000)) + (ORR ,target-reg ,regnum:assembler-temp ,target-reg))) + + +;;;; Regularized Machine Instructions + +(define (adjusted:high n) + (let ((n (->unsigned n))) + (if (< (remainder n #x10000) #x8000) + (quotient n #x10000) + (+ (quotient n #x10000) 1)))) + +(define (adjusted:low n) + (let ((remainder (remainder (->unsigned n) #x10000))) + (if (< remainder #x8000) + remainder + (- remainder #x10000)))) + +(define (low-bits offset) + (let ((bits (signed-integer->bit-string 32 offset))) + (bit-substring bits 0 10))) + +(define (high-bits offset) + (let ((bits (signed-integer->bit-string 32 offset))) + (bit-substring bits 10 32))) + +(define-integrable (top-16-bits n) + (quotient (->unsigned n) #x10000)) + +(define-integrable (bottom-16-bits n) + (remainder (->unsigned n) #x10000)) + +(define-integrable (bottom-10-bits n) + (remainder (->unsigned n) #x400)) + +(define-integrable (bottom-13-bits n) + (remainder (->unsigned n) #x2000)) + +(define-integrable (top-22-bits n) + (quotient (->unsigned n) #x400)) + +(define (->unsigned n) + (if (negative? n) (+ #x100000000 n) n)) + +(define-integrable (fits-in-16-bits-signed? value) + (<= #x-8000 value #x7fff)) + +(define-integrable (fits-in-16-bits-unsigned? value) + (<= #x0 value #xffff)) + +(define-integrable (fits-in-13-bits-signed? value) + (<= #x-2000 value #x1fff)) + +(define-integrable (fits-in-13-bits-unsigned? value) + (<= #x0 value #x1fff)) + +(define-integrable (top-16-bits-only? value) + (zero? (bottom-16-bits value))) + +(define-integrable (top-22-bits-only? value) + (zero? (bottom-10-bits value))) + +(define (copy r t) + (if (= r t) + (LAP) + (LAP (ADD ,t 0 ,r)))) + +(define (fp-copy from to) + (if (= to from) + (LAP) + (let ((to-reg (float-register->fpr to)) + (from-reg (float-register->fpr from))) + (LAP (FMOVS ,to-reg ,from-reg) + (FMOVS ,(+ to-reg 1) ,(+ from-reg 1)))))) + +;; Handled by VARIABLE-WIDTH in instr1.scm + +(define (fp-load-doubleword offset base target NOP?) + (let* ((least (float-register->fpr target)) + (most (+ least 1))) + (LAP (LDDF ,least (OFFSET ,offset ,base)) + ,@(if NOP? (LAP (NOP)) (LAP))))) + +(define (fp-store-doubleword offset base source) + (let* ((least (float-register->fpr source)) + (most (+ least 1))) + (LAP (SDDF ,least (OFFSET ,offset ,base)) + ,@(if NOP? (LAP (NOP)) (LAP))))) + +;;;; PC-relative addresses + +(define (load-pc-relative target type label delay-slot?) + ;; Load a pc-relative location's contents into a machine register. + ;; Optimization: if there is a register that contains the value of + ;; another label, use that register as the base register. + ;; Otherwise, allocate a temporary and load it with the value of the + ;; label, then use the temporary as the base register. This + ;; strategy of loading a temporary wins if the temporary is used + ;; again, but loses if it isn't, since loading the temporary takes + ;; two instructions in addition to the LW instruction, while doing a + ;; pc-relative LW instruction takes only two instructions total. + ;; But pc-relative loads of various kinds are quite common, so this + ;; should almost always be advantageous. + (with-values (lambda () (get-typed-label type)) + (lambda (label* alias) + (if label* + (LAP (LD ,target (OFFSET (- ,label ,label*) ,alias)) + ,@(if delay-slot? (LAP (NOP)) (LAP))) + (let ((temporary (standard-temporary!))) + (set-typed-label! type label temporary) + (LAP ,@(%load-pc-relative-address temporary label) + (LD ,target (OFFSET 0 ,temporary)) + ,@(if delay-slot? (LAP (NOP)) (LAP)))))))) + +(define (load-pc-relative-address target type label) + ;; Load address of a pc-relative location into a machine register. + ;; Optimization: if there is another register that contains the + ;; value of another label, add the difference between the labels to + ;; that register's contents instead. The ADDI takes one + ;; instruction, while the %LOAD-PC-RELATIVE-ADDRESS takes two, so + ;; this is always advantageous. + (let ((instructions + (with-values (lambda () (get-typed-label type)) + (lambda (label* alias) + (if label* + (LAP (ADDI ,target ,alias (- ,label ,label*))) + (%load-pc-relative-address target label)))))) + (set-typed-label! type label target) + instructions)) + +(define (%load-pc-relative-address target label) + (let ((label* (generate-label))) + (LAP (CALL 4) + (LABEL ,label*) + (ADDI ,target ,regnum:call-result (- ,label (- ,label* 4)))))) + +;;; Typed labels provide further optimization. There are two types, +;;; CODE and CONSTANT, that say whether the label is located in the +;;; code block or the constants block of the output. Statistically, +;;; a label is likely to be closer to another label of the same type +;;; than to a label of the other type. + +(define (get-typed-label type) + (let ((entries (register-map-labels *register-map* 'GENERAL))) + (let loop ((entries* entries)) + (cond ((null? entries*) + ;; If no entries of the given type, use any entry that is + ;; available. + (let loop ((entries entries)) + (cond ((null? entries) + (values false false)) + ((pair? (caar entries)) + (values (cdaar entries) (cadar entries))) + (else + (loop (cdr entries)))))) + ((and (pair? (caar entries*)) + (eq? type (caaar entries*))) + (values (cdaar entries*) (cadar entries*))) + (else + (loop (cdr entries*))))))) + +(define (set-typed-label! type label alias) + (set! *register-map* + (set-machine-register-label *register-map* alias (cons type label))) + unspecific) + +(define (immediate->register immediate) + (let ((register (get-immediate-alias immediate))) + (if register + (values (LAP) register) + (let ((temporary (standard-temporary!))) + (set! *register-map* + (set-machine-register-label *register-map* + temporary + immediate)) + (values (%load-immediate temporary immediate) temporary))))) + +(define (get-immediate-alias immediate) + (let loop ((entries (register-map-labels *register-map* 'GENERAL))) + (cond ((null? entries) + false) + ((eqv? (caar entries) immediate) + (cadar entries)) + (else + (loop (cdr entries)))))) + +(define (load-immediate target immediate record?) + (let ((registers (get-immediate-aliases immediate))) + (if (memv target registers) + (LAP) + (begin + (if record? + (set! *register-map* + (set-machine-register-label *register-map* + target + immediate))) + (if (not (null? registers)) + (LAP (ADD ,target 0 ,(car registers))) + (%load-immediate target immediate)))))) + +(define (get-immediate-aliases immediate) + (let loop ((entries (register-map-labels *register-map* 'GENERAL))) + (cond ((null? entries) + '()) + ((eqv? (caar entries) immediate) + (append (cdar entries) (loop (cdr entries)))) + (else + (loop (cdr entries)))))) + +(define (%load-immediate target immediate) + (cond ((top-22-bits-only? immediate) + (LAP (SETHI ,target ,immediate))) + ((fits-in-13-bits-signed? immediate) + (LAP (ORI ,target ,regnum:zero ,(bottom-13-bits immediate)))) + (else + (LAP (SETHI ,target ,immediate) + (ORI ,target ,target ,(bottom-10-bits immediate)))))) + +(define (add-immediate immediate source target) + (if (fits-in-13-bits-signed? immediate) + (LAP (ADDI ,target ,source ,immediate)) + (with-values (lambda () (immediate->register immediate)) + (lambda (prefix alias) + (LAP ,@prefix + (ADDU ,target ,source ,alias)))))) + +;;;; Comparisons + +(define (compare-immediate comp immediate source) + ; Branch if immediate source + (let ((cc (invert-condition-noncommutative comp))) + ;; This machine does register immediate; you can + ;; now think of cc in this way + (if (zero? immediate) + (begin + (branch-generator! cc + `(BE) `(BL) `(BG) + `(BNE) `(BGE) `(BLE)) + (LAP (SUBCCI 0 ,source 0))) + (with-values (lambda () (immediate->register immediate)) + (lambda (prefix alias) + (LAP ,@prefix + ,@(compare comp alias source))))))) + +(define (compare condition r1 r2) + ; Branch if r1 r2 + (if (= r1 r2) + (let ((branch + (lambda (label) (LAP (BA (@PCR ,label)) (NOP)))) + (dont-branch + (lambda (label) label (LAP)))) + (if (memq condition '(< > <>)) + (set-current-branches! dont-branch branch) + (set-current-branches! branch dont-branch)) + (LAP (SUBCC 0 ,r1 ,r2))) + (begin + (branch-generator! condition + `(BE) `(BL) `(BG) `(BNE) `(BGE) `(BLE)) + (LAP (SUBCC 0 ,r1 ,r2))))) + +(define (branch-generator! cc = < > <> >= <=) + (let ((forward + (case cc + ((=) =) ((<) <) ((>) >) + ((<>) <>) ((>=) >=) ((<=) <=))) + (inverse + (case cc + ((=) <>) ((<) >=) ((>) <=) + ((<>) =) ((>=) <) ((<=) >)))) + (set-current-branches! + (lambda (label) + (LAP (,@forward (@PCR ,label)) (NOP))) + (lambda (label) + (LAP (,@inverse (@PCR ,label)) (NOP)))))) + +(define (invert-condition condition) + (let ((place (assq condition condition-inversion-table))) + (if (not place) + (error "unknown condition" condition)) + (cadr place))) + +(define (invert-condition-noncommutative condition) + (let ((place (assq condition condition-inversion-table))) + (if (not place) + (error "unknown condition" condition)) + (caddr place))) + +(define condition-inversion-table + ; A OP B NOT (A OP B) B OP A + ; invert invert non-comm. + '((= <> =) + (< >= >) + (> <= <) + (<> = <>) + (<= > >=) + (>= < <=))) + +;;;; Miscellaneous + +(define-integrable (object->type source target) + ; Type extraction + (LAP (SRL ,target ,source ,(- 32 scheme-type-width)))) + +(define-integrable (object->datum source target) + ; Zero out the type field; don't put in the quad bits + (LAP (ANDR ,target ,source ,regnum:address-mask))) + +(define (object->address source target) + ; Drop in the segment bits + (LAP (ANDR ,target ,source ,regnum:address-mask) + (ADD ,target ,regnum:quad-bits ,target))) + +(define (standard-unary-conversion source target conversion) + ;; `source' is any register, `target' a pseudo register. + (let ((source (standard-source! source))) + (conversion source (standard-target! target)))) + +(define (standard-binary-conversion source1 source2 target conversion) + (let ((source1 (standard-source! source1)) + (source2 (standard-source! source2))) + (conversion source1 source2 (standard-target! target)))) + +(define (standard-source! register) + (load-alias-register! register (register-type register))) + +(define (standard-target! register) + (delete-dead-registers!) + (allocate-alias-register! register (register-type register))) + +(define-integrable (standard-temporary!) + (allocate-temporary-register! 'GENERAL)) + +(define (standard-move-to-target! source target) + (move-to-alias-register! source (register-type source) target)) + +(define (standard-move-to-temporary! source) + (move-to-temporary-register! source (register-type source))) + +(define (register-expression expression) + (case (rtl:expression-type expression) + ((REGISTER) + (rtl:register-number expression)) + ((CONSTANT) + (let ((object (rtl:constant-value expression))) + (and (zero? (object-type object)) + (zero? (object-datum object)) + 0))) + ((CONS-NON-POINTER) + (and (let ((type (rtl:cons-non-pointer-type expression))) + (and (rtl:machine-constant? type) + (zero? (rtl:machine-constant-value type)))) + (let ((datum (rtl:cons-non-pointer-datum expression))) + (and (rtl:machine-constant? datum) + (zero? (rtl:machine-constant-value datum)))) + 0)) + (else false))) + +(define (define-arithmetic-method operator methods method) + (let ((entry (assq operator (cdr methods)))) + (if entry + (set-cdr! entry method) + (set-cdr! methods (cons (cons operator method) (cdr methods))))) + operator) + +(define (lookup-arithmetic-method operator methods) + (cdr (or (assq operator (cdr methods)) + (error "Unknown operator" operator)))) + +(define-integrable (ea/mode ea) (car ea)) +(define-integrable (register-ea/register ea) (cadr ea)) +(define-integrable (offset-ea/offset ea) (cadr ea)) +(define-integrable (offset-ea/register ea) (caddr ea)) + +(define (pseudo-register-displacement register) + ;; Register block consists of 16 4-byte registers followed by 256 + ;; 8-byte temporaries. + (+ (* 4 16) (* 8 (register-renumber register)))) + +(define-integrable (float-register->fpr register) + ;; Float registers are represented by 32 through 47 in the RTL, + ;; corresponding to even registers 0 through 30 in the machine. + (- register 32)) + +(define-integrable (fpr->float-register register) + (+ register 32)) + +(define-integrable reg:memtop + (INST-EA (OFFSET #x0000 ,regnum:regs-pointer))) + +(define-integrable reg:environment + (INST-EA (OFFSET #x000C ,regnum:regs-pointer))) + +(define-integrable reg:lexpr-primitive-arity + (INST-EA (OFFSET #x001C ,regnum:regs-pointer))) + +(define-integrable reg:closure-limit + (INST-EA (OFFSET #x0024 ,regnum:regs-pointer))) + +(define-integrable reg:stack-guard + (INST-EA (OFFSET #x002C ,regnum:regs-pointer))) + +(define (lap:make-label-statement label) + (INST (LABEL ,label))) + +(define (lap:make-unconditional-branch label) + (LAP (BA (@PCR ,label)) + (NOP))) + +(define (lap:make-entry-point label block-start-label) + block-start-label + (LAP (ENTRY-POINT ,label) + ,@(make-external-label expression-code-word label))) + +;;;; Codes and Hooks + +(let-syntax ((define-codes + (macro (start . names) + (define (loop names index) + (if (null? names) + '() + (cons `(DEFINE-INTEGRABLE + ,(symbol-append 'CODE:COMPILER- + (car names)) + ,index) + (loop (cdr names) (1+ index))))) + `(BEGIN ,@(loop names start))))) + (define-codes #x012 + primitive-apply primitive-lexpr-apply + apply error lexpr-apply link + interrupt-closure interrupt-dlink interrupt-procedure + interrupt-continuation interrupt-ic-procedure + assignment-trap cache-reference-apply + reference-trap safe-reference-trap unassigned?-trap + -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero? + access lookup safe-lookup unassigned? unbound? + set! define lookup-apply)) + +(define-integrable (link-to-interface code) + ;; Jump to link-to-interface with link in C_arg1 + (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -4) + (JALR ,regnum:first-arg ,regnum:assembler-temp) + (ADDI ,regnum:interface-index 0 ,(* 4 code)))) + +(define-integrable (link-to-trampoline code) + ;; Jump, with link in 31, to trampoline_to_interface + ;; Jump, with link in C_arg1 to scheme-to-interface + (LAP (JALR ,regnum:first-arg ,regnum:scheme-to-interface) + (ADDI ,regnum:interface-index 0 ,(* 4 code)))) + +(define-integrable (invoke-interface code) + ;; Jump to scheme-to-interface + (LAP (JALR ,regnum:assembler-temp ,regnum:scheme-to-interface) + (ADDI ,regnum:interface-index 0 ,(* 4 code)))) + +(define (load-interface-args! first second third fourth) + (let ((clear-regs + (apply clear-registers! + (append (if first (list regnum:first-arg) '()) + (if second (list regnum:second-arg) '()) + (if third (list regnum:third-arg) '()) + (if fourth (list regnum:fourth-arg) '())))) + (load-reg + (lambda (reg arg) + (if reg (load-machine-register! reg arg) (LAP))))) + (let ((load-regs + (LAP ,@(load-reg first regnum:first-arg) + ,@(load-reg second regnum:second-arg) + ,@(load-reg third regnum:third-arg) + ,@(load-reg fourth regnum:fourth-arg)))) + (LAP ,@clear-regs + ,@load-regs + ,@(clear-map!))))) + +(define (require-register! machine-reg) + (flush-register! machine-reg) + (need-register! machine-reg)) + +(define-integrable (flush-register! machine-reg) + (prefix-instructions! (clear-registers! machine-reg))) + +(define (rtl-target:=machine-register! rtl-reg machine-reg) + (if (machine-register? rtl-reg) + (begin + (require-register! machine-reg) + (if (not (= rtl-reg machine-reg)) + (suffix-instructions! + (register->register-transfer machine-reg rtl-reg)))) + (begin + (delete-register! rtl-reg) + (flush-register! machine-reg) + (add-pseudo-register-alias! rtl-reg machine-reg)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/lapopt.scm b/v7/src/compiler/machines/sparc/lapopt.scm new file mode 100644 index 000000000..42df87f44 --- /dev/null +++ b/v7/src/compiler/machines/sparc/lapopt.scm @@ -0,0 +1,106 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/lapopt.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1991 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Optimizer for MIPS. + +(declare (usual-integrations)) + +(define (optimize-linear-lap instructions) + instructions) + +#| +(define (optimize-linear-lap instructions) + ;; Find occurrences of LW/LBU/LWC1 followed by NOP, and delete the + ;; NOP if the instruction following it has no reference to the + ;; target register of the load. + + ;; **** This is pretty fragile. **** + (letrec + ((find-load + (lambda (instructions) + (cond ((null? instructions) '()) + ((and (pair? (car instructions)) + (or (eq? 'LW (caar instructions)) + (eq? 'LBU (caar instructions)) + (eq? 'LWC1 (caar instructions)))) + instructions) + (else (find-load (cdr instructions)))))) + (get-next + (lambda (instructions) + (let ((instructions (cdr instructions))) + (cond ((null? instructions) '()) + ((or (not (pair? (car instructions))) + (eq? 'LABEL (caar instructions)) + (eq? 'COMMENT (caar instructions))) + (get-next instructions)) + (else instructions))))) + (refers-to-register? + (lambda (instruction register) + (let loop ((x instruction)) + (if (pair? x) + (or (loop (car x)) + (loop (cdr x))) + (eqv? register x)))))) + (let loop ((instructions instructions)) + (let ((first (find-load instructions))) + (if (not (null? first)) + (let ((second (get-next first))) + (if (not (null? second)) + (let ((third (get-next second))) + (if (not (null? third)) + (if (and (equal? '(NOP) (car second)) + ;; This is a crude way to test for a + ;; reference to the target register + ;; -- it will sometimes incorrectly + ;; say that there is a reference, but + ;; it will never incorrectly say that + ;; there is no reference. + (not (refers-to-register? (car third) + (cadar first))) + (or (not (and (eq? 'LWC1 (caar first)) + (odd? (cadar first)))) + (not (refers-to-register? + (car third) + (- (cadar first) 1))))) + (begin + (let loop ((this (cdr first)) (prev first)) + (if (eq? second this) + (set-cdr! prev (cdr this)) + (loop (cdr this) this))) + (loop (if (equal? '(NOP) (car third)) + first + third))) + (loop second)))))))))) + instructions) +|# \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/machin.scm b/v7/src/compiler/machines/sparc/machin.scm new file mode 100644 index 000000000..c0cc91d4b --- /dev/null +++ b/v7/src/compiler/machines/sparc/machin.scm @@ -0,0 +1,409 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/machin.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1988-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Machine Model for SPARC +;;; package: (compiler) + +(declare (usual-integrations)) + +;;;; Architecture Parameters + +(define use-pre/post-increment? false) +(define endianness 'BIG) +(define-integrable addressing-granularity 8) +(define-integrable scheme-object-width 32) +(define-integrable scheme-type-width 6) ;or 8 +(define-integrable type-scale-factor (expt 2 (- 8 scheme-type-width))) + +(define-integrable scheme-datum-width + (- scheme-object-width scheme-type-width)) + +(define-integrable flonum-size 2) +(define-integrable float-alignment 64) + +;;; It is currently required that both packed characters and objects +;;; be integrable numbers of address units. Furthermore, the number +;;; of address units per object must be an integral multiple of the +;;; number of address units per character. This will cause problems +;;; on a machine that is word addressed, in which case we will have to +;;; rethink the character addressing strategy. + +(define-integrable address-units-per-object + (quotient scheme-object-width addressing-granularity)) + +(define-integrable address-units-per-packed-char 1) + +(define-integrable signed-fixnum/upper-limit (expt 2 (-1+ scheme-datum-width))) +(define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit)) +(define-integrable unsigned-fixnum/upper-limit (* 2 signed-fixnum/upper-limit)) + +(define-integrable (stack->memory-offset offset) offset) +(define-integrable ic-block-first-parameter-offset 2) +(define-integrable execute-cache-size 3) ; Long words per UUO link slot +(define-integrable closure-entry-size + ;; Long words in a single closure entry: + ;; Format + GC offset word + ;; SETHI + ;; JALR/JAL + ;; ADDI + 4) + +;; Given: the number of entry points in a closure, and a particular +;; entry point number. Return: the distance from that entry point to +;; the first variable slot in the closure (in words). + +(define (closure-first-offset nentries entry) + (if (zero? nentries) + 1 ; Strange boundary case + (- (* closure-entry-size (- nentries entry)) 1))) + +;; Like the above, but from the start of the complete closure object, +;; viewed as a vector, and including the header word. + +(define (closure-object-first-offset nentries) + (case nentries + ((0) + ;; Vector header only + 1) + ((1) + ;; Manifest closure header followed by single entry point + (+ 1 closure-entry-size)) + (else + ;; Manifest closure header, number of entries, then entries. + (+ 1 1 (* closure-entry-size nentries))))) + +;; Bump from one entry point to another -- distance in BYTES + +(define (closure-entry-distance nentries entry entry*) + nentries ; ignored + (* (* closure-entry-size 4) (- entry* entry))) + +;; Bump to the canonical entry point. On a RISC (which forces +;; longword alignment for entry points anyway) there is no need to +;; canonicalize. + +(define (closure-environment-adjustment nentries entry) + nentries entry ; ignored + 0) + +;;;; Machine Registers + +(define-integrable g0 0) +(define-integrable g1 1) +(define-integrable g2 2) +(define-integrable g3 3) +(define-integrable g4 4) +(define-integrable g5 5) +(define-integrable g6 6) +(define-integrable g7 7) +(define-integrable g8 8) +(define-integrable g9 9) +(define-integrable g10 10) +(define-integrable g11 11) +(define-integrable g12 12) +(define-integrable g13 13) +(define-integrable g14 14) +(define-integrable g15 15) +(define-integrable g16 16) +(define-integrable g17 17) +(define-integrable g18 18) +(define-integrable g19 19) +(define-integrable g20 20) +(define-integrable g21 21) +(define-integrable g22 22) +(define-integrable g23 23) +(define-integrable g24 24) +(define-integrable g25 25) +(define-integrable g26 26) +(define-integrable g27 27) +(define-integrable g28 28) +(define-integrable g29 29) +(define-integrable g30 30) +(define-integrable g31 31) + +;; Floating point general registers -- the odd numbered ones are +;; only used when transferring to/from the CPU +(define-integrable fp0 32) +(define-integrable fp1 33) +(define-integrable fp2 34) +(define-integrable fp3 35) +(define-integrable fp4 36) +(define-integrable fp5 37) +(define-integrable fp6 38) +(define-integrable fp7 39) +(define-integrable fp8 40) +(define-integrable fp9 41) +(define-integrable fp10 42) +(define-integrable fp11 43) +(define-integrable fp12 44) +(define-integrable fp13 45) +(define-integrable fp14 46) +(define-integrable fp15 47) +(define-integrable fp16 48) +(define-integrable fp17 49) +(define-integrable fp18 50) +(define-integrable fp19 51) +(define-integrable fp20 52) +(define-integrable fp21 53) +(define-integrable fp22 54) +(define-integrable fp23 55) +(define-integrable fp24 56) +(define-integrable fp25 57) +(define-integrable fp26 58) +(define-integrable fp27 59) +(define-integrable fp28 60) +(define-integrable fp29 61) +(define-integrable fp30 62) +(define-integrable fp31 63) + +(define-integrable number-of-machine-registers 64) +(define-integrable number-of-temporary-registers 256) + +;;; Fixed-use registers for Scheme compiled code. +(define-integrable regnum:return-value g16) +(define-integrable regnum:stack-pointer g17) +(define-integrable regnum:memtop g18) +(define-integrable regnum:free g19) +(define-integrable regnum:scheme-to-interface g20) +(define-integrable regnum:dynamic-link g21) +(define-integrable regnum:closure-free g22) +(define-integrable regnum:address-mask g25) +(define-integrable regnum:regs-pointer g26) +(define-integrable regnum:quad-bits g27) +(define-integrable regnum:closure-hook g28) +(define-integrable regnum:interface-index g13) + +;;; Fixed-use registers due to architecture or OS calling conventions. +(define-integrable regnum:zero g0) +(define-integrable regnum:assembler-temp g1) +(define-integrable regnum:C-return-receive-value g8) +(define-integrable regnum:C-return-send-value g24) +(define-integrable regnum:C-stack-pointer g14) +(define-integrable regnum:first-arg g8) +(define-integrable regnum:second-arg g9) +(define-integrable regnum:third-arg g10) +(define-integrable regnum:fourth-arg g11) +(define-integrable regnum:fifth-arg g12) +(define-integrable regnum:sixth-arg g13) +(define-integrable regnum:reserved-global-1 g2) +(define-integrable regnum:reserved-global-2 g3) +(define-integrable regnum:reserved-global-3 g4) +(define-integrable regnum:reserved-global-4 g5) +(define-integrable regnum:reserved-global-5 g6) +(define-integrable regnum:reserved-global-6 g7) +(define-integrable regnum:linkage g31) +(define-integrable regnum:call-result g15) + +(define address-regs + (list regnum:stack-pointer regnum:memtop regnum:free regnum:dynamic-link + regnum:linkage)) + +(define object-regs + (list regnum:return-value regnum:C-return-send-value)) + +(define immediate-regs + (list regnum:address-mask regnum:quad-bits)) + +(define unboxed-regs + (list regnum:scheme-to-interface + regnum:regs-pointer regnum:assembler-temp + regnum:reserved-global-4 + regnum:reserved-global-5 + regnum:reserved-global-6 + regnum:C-stack-pointer + )) + +(define machine-register-value-class + (lambda (register) + (cond ((member register address-regs) value-class=address) + ((member register object-regs) value-class=object) + ((member register immediate-regs) value-class=immediate) + ((member register unboxed-regs) value-class=unboxed) + ((<= g0 register g31) value-class=word) + ((<= fp0 register fp31) value-class=float) + (else (error "illegal machine register" register))))) + +(define-integrable (machine-register-known-value register) + register ;ignore + false) + +;;;; Interpreter Registers + +(define-integrable (interpreter-free-pointer) + (rtl:make-machine-register regnum:free)) + +(define (interpreter-free-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:free))) + +(define-integrable (interpreter-regs-pointer) + (rtl:make-machine-register regnum:regs-pointer)) + +(define (interpreter-regs-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:regs-pointer))) + +(define-integrable (interpreter-value-register) + (rtl:make-machine-register regnum:return-value)) + +(define (interpreter-value-register? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:return-value))) + +(define-integrable (interpreter-stack-pointer) + (rtl:make-machine-register regnum:stack-pointer)) + +(define (interpreter-stack-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:stack-pointer))) + +(define-integrable (interpreter-dynamic-link) + (rtl:make-machine-register regnum:dynamic-link)) + +(define (interpreter-dynamic-link? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:dynamic-link))) + +(define-integrable (interpreter-environment-register) + (rtl:make-offset (interpreter-regs-pointer) 3)) + +(define (interpreter-environment-register? expression) + (and (rtl:offset? expression) + (interpreter-regs-pointer? (rtl:offset-base expression)) + (= 3 (rtl:offset-number expression)))) + +(define-integrable (interpreter-register:access) + (rtl:make-machine-register regnum:C-return-send-value)) + +(define-integrable (interpreter-register:cache-reference) + (rtl:make-machine-register regnum:C-return-send-value)) + +(define-integrable (interpreter-register:cache-unassigned?) + (rtl:make-machine-register regnum:C-return-send-value)) + +(define-integrable (interpreter-register:lookup) + (rtl:make-machine-register regnum:C-return-send-value)) + +(define-integrable (interpreter-register:unassigned?) + (rtl:make-machine-register regnum:C-return-send-value)) + +(define-integrable (interpreter-register:unbound?) + (rtl:make-machine-register regnum:C-return-send-value)) + +;;;; RTL Registers, Constants, and Primitives + +(define (rtl:machine-register? rtl-register) + (case rtl-register + ((STACK-POINTER) + (interpreter-stack-pointer)) + ((DYNAMIC-LINK) + (interpreter-dynamic-link)) + ((VALUE) + (interpreter-value-register)) + ((INTERPRETER-CALL-RESULT:ACCESS) + (interpreter-register:access)) + ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) + (interpreter-register:cache-reference)) + ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) + (interpreter-register:cache-unassigned?)) + ((INTERPRETER-CALL-RESULT:LOOKUP) + (interpreter-register:lookup)) + ((INTERPRETER-CALL-RESULT:UNASSIGNED?) + (interpreter-register:unassigned?)) + ((INTERPRETER-CALL-RESULT:UNBOUND?) + (interpreter-register:unbound?)) + (else false))) + +(define (rtl:interpreter-register? rtl-register) + (case rtl-register + ((MEMORY-TOP) 0) + ((STACK-GUARD) 1) + ((ENVIRONMENT) 3) + ((TEMPORARY) 4) + (else false))) + +(define (rtl:interpreter-register->offset locative) + (or (rtl:interpreter-register? locative) + (error "Unknown register type" locative))) + +(define (rtl:constant-cost expression) + ;; Magic numbers. + (let ((if-integer + (lambda (value) + (cond ((zero? value) 1) + ((or (fits-in-16-bits-signed? value) + (fits-in-16-bits-unsigned? value) + (top-16-bits-only? value)) + 2) + (else 3))))) + (let ((if-synthesized-constant + (lambda (type datum) + (if-integer (make-non-pointer-literal type datum))))) + (case (rtl:expression-type expression) + ((CONSTANT) + (let ((value (rtl:constant-value expression))) + (if (non-pointer-object? value) + (if-synthesized-constant (object-type value) + (object-datum value)) + 3))) + ((MACHINE-CONSTANT) + (if-integer (rtl:machine-constant-value expression))) + ((ENTRY:PROCEDURE + ENTRY:CONTINUATION + ASSIGNMENT-CACHE + VARIABLE-CACHE + OFFSET-ADDRESS) + 3) + ((CONS-NON-POINTER) + (and (rtl:machine-constant? (rtl:cons-non-pointer-type expression)) + (rtl:machine-constant? (rtl:cons-non-pointer-datum expression)) + (if-synthesized-constant + (rtl:machine-constant-value + (rtl:cons-non-pointer-type expression)) + (rtl:machine-constant-value + (rtl:cons-non-pointer-datum expression))))) + (else false))))) + +(define compiler:open-code-floating-point-arithmetic? + true) + +(set! compiler:open-code-primitives? #f) + +(define compiler:primitives-with-no-open-coding + '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER + FIXNUM-NOT FIXNUM-AND FIXNUM-ANDC FIXNUM-OR FIXNUM-XOR FIXNUM-LSH + INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER + FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS + FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND + FLONUM-REMAINDER FLONUM-SQRT)) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/make.scm b/v7/src/compiler/machines/sparc/make.scm new file mode 100644 index 000000000..cf9155d00 --- /dev/null +++ b/v7/src/compiler/machines/sparc/make.scm @@ -0,0 +1,45 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/make.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1988-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler: System Construction + +(declare (usual-integrations)) + +(package/system-loader "comp" '() 'QUERY) +(for-each (lambda (name) + ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) + '((COMPILER MACROS) + (COMPILER DECLARATIONS))) +(set! (access endianness (->environment '(COMPILER))) 'BIG) +(add-system! (make-system "Liar (SPARC)" 4 87 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/rgspcm.scm b/v7/src/compiler/machines/sparc/rgspcm.scm new file mode 100644 index 000000000..5cc90eb60 --- /dev/null +++ b/v7/src/compiler/machines/sparc/rgspcm.scm @@ -0,0 +1,75 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rgspcm.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ +$MC68020-Header: /scheme/compiler/bobcat/RCS/rgspcm.scm,v 4.2 1991/05/06 23:17:03 jinx Exp $ + +Copyright (c) 1987-1991 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Generation: Special primitive combinations. Spectrum version. + +(declare (usual-integrations)) + +(define (define-special-primitive-handler name handler) + (let ((primitive (make-primitive-procedure name true))) + (let ((entry (assq primitive special-primitive-handlers))) + (if entry + (set-cdr! entry handler) + (set! special-primitive-handlers + (cons (cons primitive handler) + special-primitive-handlers))))) + name) + +(define (special-primitive-handler primitive) + (let ((entry (assq primitive special-primitive-handlers))) + (and entry + (cdr entry)))) + +(define special-primitive-handlers + '()) + +(define (define-special-primitive/standard primitive) + (define-special-primitive-handler primitive + rtl:make-invocation:special-primitive)) + +(define-special-primitive/standard '&+) +(define-special-primitive/standard '&-) +(define-special-primitive/standard '&*) +(define-special-primitive/standard '&/) +(define-special-primitive/standard '&=) +(define-special-primitive/standard '&<) +(define-special-primitive/standard '&>) +(define-special-primitive/standard '1+) +(define-special-primitive/standard '-1+) +(define-special-primitive/standard 'zero?) +(define-special-primitive/standard 'positive?) +(define-special-primitive/standard 'negative?) +(define-special-primitive/standard 'quotient) +(define-special-primitive/standard 'remainder) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/rules1.scm b/v7/src/compiler/machines/sparc/rules1.scm new file mode 100644 index 000000000..43466cc35 --- /dev/null +++ b/v7/src/compiler/machines/sparc/rules1.scm @@ -0,0 +1,310 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rules1.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1989-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Data Transfers + +(declare (usual-integrations)) + +;;;; Simple Operations + +;;; All assignments to pseudo registers are required to delete the +;;; dead registers BEFORE performing the assignment. However, it is +;;; necessary to derive the effective address of the source +;;; expression(s) before deleting the dead registers. Otherwise any +;;; source expression containing dead registers might refer to aliases +;;; which have been reused. + +(define-rule statement + (ASSIGN (REGISTER (? target)) (REGISTER (? source))) + (standard-move-to-target! source target) + (LAP)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum)))) + (let* ((type (standard-move-to-temporary! type)) + (target (standard-move-to-target! datum target))) + (LAP (SLL ,type ,type ,(- 32 scheme-type-width)) + (ANDR ,target ,target ,regnum:address-mask) + (ORR ,target ,type ,target)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (REGISTER (? type)) (REGISTER (? datum)))) + (let* ((type (standard-move-to-temporary! type)) + (target (standard-move-to-target! datum target))) + (LAP (SLL ,type ,type ,(- 32 scheme-type-width)) + (ORR ,target ,type ,target)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source)))) + (let ((target (standard-move-to-target! source target))) + (deposit-type type target))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source)))) + (standard-unary-conversion source target + (lambda (source target) + (deposit-type type source)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) + (standard-unary-conversion source target object->type)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) + (standard-unary-conversion source target object->datum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) + (standard-unary-conversion source target object->address)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OFFSET-ADDRESS (REGISTER (? source)) (? offset))) + (standard-unary-conversion source target + (lambda (source target) + (add-immediate (* 4 offset) source target)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? offset))) + (standard-unary-conversion source target + (lambda (source target) + (add-immediate offset source target)))) + +;;;; Loading of Constants + +(define-rule statement + ;; load a machine constant + (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source))) + (load-immediate (standard-target! target) source #T)) + +(define-rule statement + ;; load a Scheme constant + (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) + (load-constant (standard-target! target) source #T #T)) + +(define-rule statement + ;; load the type part of a Scheme constant + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant)))) + (load-immediate (standard-target! target) + (make-non-pointer-literal 0 (object-type constant)) + #T)) + +(define-rule statement + ;; load the datum part of a Scheme constant + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) + (QUALIFIER (non-pointer-object? constant)) + (load-immediate (standard-target! target) + (make-non-pointer-literal 0 (careful-object-datum constant)) + #T)) + +(define-rule statement + ;; load a synthesized constant + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (load-immediate (standard-target! target) + (make-non-pointer-literal type datum) + #T)) + +(define-rule statement + ;; load the address of a variable reference cache + (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) + (load-pc-relative (standard-target! target) + 'CONSTANT + (free-reference-label name) + true)) + +(define-rule statement + ;; load the address of an assignment cache + (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) + (load-pc-relative (standard-target! target) + 'CONSTANT + (free-assignment-label name) + true)) + +(define-rule statement + ;; load the address of a procedure's entry point + (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) + (load-pc-relative-address (standard-target! target) 'CODE label)) + +(define-rule statement + ;; load the address of a continuation + (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) + (load-pc-relative-address (standard-target! target) 'CODE label)) + +(define-rule statement + ;; load a procedure object + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (load-entry target type label)) + +(define-rule statement + ;; load a return address object + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:CONTINUATION (? label)))) + (load-entry target type label)) + +(define (load-entry target type label) + (let ((temporary (standard-temporary!)) + (target (standard-target! target))) + ;; Loading the address into a temporary makes it more useful, + ;; because it can be reused later. + (LAP ,@(load-pc-relative-address temporary 'CODE label) + (ADDI ,target ,temporary 0) + ,@(deposit-type type target)))) + +;;;; Transfers from memory + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) + (standard-unary-conversion address target + (lambda (address target) + (LAP (LD ,target (OFFSET ,(* 4 offset) ,address)) + (NOP))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 17) 1)) + (LAP (LD ,(standard-target! target) (OFFSET 0 ,regnum:stack-pointer)) + (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4))) + +;;;; Transfers to memory + +(define-rule statement + ;; store an object in memory + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) + (? source register-expression)) + (QUALIFIER (word-register? source)) + (LAP (ST ,(standard-source! source) + (OFFSET ,(* 4 offset) ,(standard-source! address))))) + +(define-rule statement + ;; Push an object register on the heap + (ASSIGN (POST-INCREMENT (REGISTER 19) 1) + (? source register-expression)) + (QUALIFIER (word-register? source)) + (LAP (ST ,(standard-source! source) (OFFSET 0 ,regnum:free)) + (ADDI ,regnum:free ,regnum:free 4))) + +(define-rule statement + ;; Push an object register on the stack + (ASSIGN (PRE-INCREMENT (REGISTER 17) -1) + (? source register-expression)) + (QUALIFIER (word-register? source)) + (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4) + (ST ,(standard-source! source) + (OFFSET 0 ,regnum:stack-pointer)))) + +;; Cheaper, common patterns. + +(define-rule statement + (ASSIGN (OFFSET (REGISTER (? address)) (? offset)) + (MACHINE-CONSTANT 0)) + (LAP (ST 0 (OFFSET ,(* 4 offset) ,(standard-source! address))))) + +(define-rule statement + ; Push NIL (or whatever is represented by a machine 0) on heap + (ASSIGN (POST-INCREMENT (REGISTER 19) 1) (MACHINE-CONSTANT 0)) + (LAP (ST 0 (OFFSET 0 ,regnum:free)) + (ADDI ,regnum:free ,regnum:free 4))) + +(define-rule statement + ; Ditto, but on stack + (ASSIGN (PRE-INCREMENT (REGISTER 17) -1) (MACHINE-CONSTANT 0)) + (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4) + (ST 0 (OFFSET 0 ,regnum:stack-pointer)))) + +;;;; CHAR->ASCII/BYTE-OFFSET + +(define-rule statement + ;; load char object from memory and convert to ASCII byte + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset)))) + (standard-unary-conversion address target + (lambda (address target) + (LAP (LDUB ,target + (OFFSET ,(let ((offset (* 4 offset))) + (if (eq? endianness 'LITTLE) + offset + (+ offset 3))) + ,address)) + (NOP))))) + +(define-rule statement + ;; load ASCII byte from memory + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET (REGISTER (? address)) (? offset))) + (standard-unary-conversion address target + (lambda (address target) + (LAP (LDUB ,target (OFFSET ,offset ,address)) + (NOP))))) + +(define-rule statement + ;; convert char object to ASCII byte + ;; Missing optimization: If source is home and this is the last + ;; reference (it is dead afterwards), an LB could be done instead of + ;; an LW followed by an ANDI. This is unlikely since the value will + ;; be home only if we've spilled it, which happens rarely. + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (REGISTER (? source)))) + (standard-unary-conversion source target + (lambda (source target) + (LAP (ANDI ,target ,source #xFF))))) + +(define-rule statement + ;; store null byte in memory + (ASSIGN (BYTE-OFFSET (REGISTER (? source)) (? offset)) + (CHAR->ASCII (CONSTANT #\NUL))) + (LAP (STB 0 (OFFSET ,offset ,(standard-source! source))))) + +(define-rule statement + ;; store ASCII byte in memory + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (REGISTER (? source))) + (LAP (STB ,(standard-source! source) + (OFFSET ,offset ,(standard-source! address))))) + +(define-rule statement + ;; convert char object to ASCII byte and store it in memory + ;; register + byte offset <- contents of register (clear top bits) + (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset)) + (CHAR->ASCII (REGISTER (? source)))) + (LAP (STB ,(standard-source! source) + (OFFSET ,offset ,(standard-source! address))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/rules2.scm b/v7/src/compiler/machines/sparc/rules2.scm new file mode 100644 index 000000000..22bde757c --- /dev/null +++ b/v7/src/compiler/machines/sparc/rules2.scm @@ -0,0 +1,86 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rules2.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1988-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Predicates + +(declare (usual-integrations)) + +(define-rule predicate + ;; test for two registers EQ? + (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2))) + (compare '= (standard-source! source1) (standard-source! source2))) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register))) + (eq-test/constant*register constant register)) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant))) + (eq-test/constant*register constant register)) + +(define (eq-test/constant*register constant source) + (let ((source (standard-source! source))) + (if (non-pointer-object? constant) + (compare-immediate '= (non-pointer->literal constant) source) + (let ((temp (standard-temporary!))) + (LAP ,@(load-pc-relative temp + 'CONSTANT (constant->label constant) + #T) + ,@(compare '= temp source)))))) + +(define-rule predicate + ;; test for register EQ? to synthesized constant + (EQ-TEST (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum))) + (REGISTER (? register))) + (eq-test/synthesized-constant*register type datum register)) + +(define-rule predicate + ;; test for register EQ? to synthesized constant + (EQ-TEST (REGISTER (? register)) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (eq-test/synthesized-constant*register type datum register)) + +(define (eq-test/synthesized-constant*register type datum source) + (compare-immediate '= + (make-non-pointer-literal type datum) + (standard-source! source))) + +(define-rule predicate + ;; Branch if virtual register contains the specified type number + (TYPE-TEST (REGISTER (? register)) (? type)) + (compare-immediate '= type (standard-source! register))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/rules3.scm b/v7/src/compiler/machines/sparc/rules3.scm new file mode 100644 index 000000000..67a5a2992 --- /dev/null +++ b/v7/src/compiler/machines/sparc/rules3.scm @@ -0,0 +1,814 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rules3.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1988-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Invocations and Entries +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Invocations + +(define-rule statement + (POP-RETURN) + (pop-return)) + +(define (pop-return) + (let ((temp (standard-temporary!))) + (LAP ,@(clear-map!) + (LD ,temp (OFFSET 0 ,regnum:stack-pointer)) + (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4) + ,@(object->address temp temp) + (JR ,temp) + (NOP)))) ; DELAY SLOT + +(define-rule statement + (INVOCATION:APPLY (? frame-size) (? continuation)) + continuation ;ignore + (LAP ,@(clear-map!) + ,@(load-immediate regnum:second-arg frame-size #F) + (LD ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer)) + (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4) + ,@(invoke-interface code:compiler-apply))) + +(define-rule statement + (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) + frame-size continuation ;ignore + (LAP ,@(clear-map!) + (BA (@PCR ,label)) + (NOP))) ; DELAY SLOT + +(define-rule statement + (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation)) + frame-size continuation ;ignore + ;; It expects the procedure at the top of the stack + (pop-return)) + +(define-rule statement + (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) + continuation ;ignore + (let* ((clear-second-arg (clear-registers! regnum:first-arg)) + (load-second-arg + (load-pc-relative-address regnum:first-arg 'CODE label))) + (LAP ,@clear-second-arg + ,@load-second-arg + ,@(clear-map!) + ,@(load-immediate regnum:second-arg number-pushed #F) + ,@(invoke-interface code:compiler-lexpr-apply)))) + +(define-rule statement + (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation)) + continuation ;ignore + ;; Destination address is at TOS; pop it into second-arg + (LAP ,@(clear-map!) + (LD ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer)) + (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4) + ,@(object->address regnum:first-arg regnum:first-arg) + ,@(load-immediate regnum:second-arg number-pushed #F) + ,@(invoke-interface code:compiler-lexpr-apply))) + +(define-rule statement + (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) + continuation ;ignore + (LAP ,@(clear-map!) + (BA (@PCR ,(free-uuo-link-label name frame-size))) + (NOP))) + +(define-rule statement + (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name)) + continuation ;ignore + (LAP ,@(clear-map!) + (BA (@PCR ,(global-uuo-link-label name frame-size))) + (NOP))) ; DELAY SLOT + +(define-rule statement + (INVOCATION:CACHE-REFERENCE (? frame-size) + (? continuation) + (? extension register-expression)) + continuation ;ignore + (let* ((clear-third-arg (clear-registers! regnum:second-arg)) + (load-third-arg + (load-pc-relative-address regnum:second-arg 'CODE *block-label*))) + (LAP ,@clear-third-arg + ,@load-third-arg + ,@(load-interface-args! extension false false false) + ,@(load-immediate regnum:third-arg frame-size #F) + ,@(invoke-interface code:compiler-cache-reference-apply)))) + +(define-rule statement + (INVOCATION:LOOKUP (? frame-size) + (? continuation) + (? environment register-expression) + (? name)) + continuation ;ignore + (LAP ,@(load-interface-args! environment false false false) + ,@(load-constant regnum:second-arg name #F #F) + ,@(load-immediate regnum:third-arg frame-size #F) + ,@(invoke-interface code:compiler-lookup-apply))) + +(define-rule statement + (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) + continuation ;ignore + (if (eq? primitive compiled-error-procedure) + (LAP ,@(clear-map!) + ,@(load-immediate regnum:first-arg frame-size #F) + ,@(invoke-interface code:compiler-error)) + (let* ((clear-second-arg (clear-registers! regnum:second-arg)) + (load-second-arg + (load-pc-relative regnum:first-arg + 'CONSTANT + (constant->label primitive) + false))) + (LAP ,@clear-second-arg + ,@load-second-arg + ,@(clear-map!) + ,@(let ((arity (primitive-procedure-arity primitive))) + (cond ((not (negative? arity)) + (invoke-interface code:compiler-primitive-apply)) + ((= arity -1) + (LAP ,@(load-immediate regnum:assembler-temp + (-1+ frame-size) + #F) + (ST ,regnum:assembler-temp + ,reg:lexpr-primitive-arity) + ,@(invoke-interface + code:compiler-primitive-lexpr-apply))) + (else + ;; Unknown primitive arity. Go through apply. + (LAP ,@(load-immediate regnum:second-arg frame-size #F) + ,@(invoke-interface code:compiler-apply))))))))) + +(let-syntax + ((define-special-primitive-invocation + (macro (name) + `(DEFINE-RULE STATEMENT + (INVOCATION:SPECIAL-PRIMITIVE + (? FRAME-SIZE) + (? CONTINUATION) + ,(make-primitive-procedure name true)) + FRAME-SIZE CONTINUATION + ,(list 'LAP + (list 'UNQUOTE-SPLICING '(CLEAR-MAP!)) + (list 'UNQUOTE-SPLICING + `(INVOKE-INTERFACE + ,(symbol-append 'CODE:COMPILER- name)))))))) + (define-special-primitive-invocation &+) + (define-special-primitive-invocation &-) + (define-special-primitive-invocation &*) + (define-special-primitive-invocation &/) + (define-special-primitive-invocation &=) + (define-special-primitive-invocation &<) + (define-special-primitive-invocation &>) + (define-special-primitive-invocation 1+) + (define-special-primitive-invocation -1+) + (define-special-primitive-invocation zero?) + (define-special-primitive-invocation positive?) + (define-special-primitive-invocation negative?)) + +;;;; 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 3)) + (LAP)) + +(define-rule statement + ;; Move words back to dynamic link marker + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 11)) + (generate/move-frame-up frame-size + (lambda (reg) (LAP (ADD ,reg 0 ,regnum:dynamic-link))))) + +(define-rule statement + ;; Move words back to dynamic link marker + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? dest))) + (generate/move-frame-up frame-size + (lambda (reg) (LAP (ADD ,reg 0 ,dest))))) + +(define-rule statement + ;; Move words back to SP+offset + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) + (OFFSET-ADDRESS (REGISTER 3) (? offset))) + (let ((how-far (* 4 (- offset frame-size)))) + (cond ((zero? how-far) + (LAP)) + ((negative? how-far) + (error "invocation-prefix:move-frame-up: bad specs" + frame-size offset)) + ((zero? frame-size) + (add-immediate how-far regnum:stack-pointer regnum:stack-pointer)) + ((= frame-size 1) + (let ((temp (standard-temporary!))) + (LAP (LD ,temp (OFFSET 0 ,regnum:stack-pointer)) + (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far) + (STW ,temp (OFFSET 0 ,regnum:stack-pointer))))) + ((= frame-size 2) + (let ((temp1 (standard-temporary!)) + (temp2 (standard-temporary!))) + (LAP (LD ,temp1 (OFFSET 0 ,regnum:stack-pointer)) + (LD ,temp2 (OFFSET 4 ,regnum:stack-pointer)) + (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far) + (ST ,temp1 (OFFSET 0 ,regnum:stack-pointer)) + (ST ,temp2 (OFFSET 4 ,regnum:stack-pointer))))) + (else + (generate/move-frame-up frame-size + (lambda (reg) + (add-immediate (* 4 offset) regnum:stack-pointer reg))))))) + +(define-rule statement + ;; Move words back to base virtual register + offset + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) + (OFFSET-ADDRESS (REGISTER (? base)) + (? offset))) + (QUALIFIER (not (= base 3))) + (generate/move-frame-up frame-size + (lambda (reg) + (add-immediate (* 4 offset) (standard-source! base) reg)))) + +(define (generate/move-frame-up frame-size destination-generator) + (let ((temp (standard-temporary!))) + (LAP ,@(destination-generator temp) + ,@(generate/move-frame-up* frame-size temp)))) + +;;; DYNAMIC-LINK instructions have a , , +;;; and as arguments. They pop the stack by +;;; removing the lesser of the amount needed to move the stack pointer +;;; back to the or . The last +;;; words on the stack (the stack frame for the procedure +;;; about to be called) are then put back onto the newly adjusted +;;; stack. + +(define-rule statement + (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) + (REGISTER (? source)) + (REGISTER 11)) + (if (and (zero? frame-size) + (= source regnum:stack-pointer)) + (LAP) + (let ((env-reg (standard-move-to-temporary! source)) + (label (generate-label))) + (LAP (SLTU ,regnum:assembler-temp ,env-reg ,regnum:dynamic-link) + (BNE 0 ,regnum:assembler-temp (@PCR ,label)) + (NOP) + (ADD ,env-reg 0 ,regnum:dynamic-link) + (LABEL ,label) + ,@(generate/move-frame-up* frame-size env-reg))))) + +(define (generate/move-frame-up* frame-size destination) + ;; Destination is guaranteed to be a machine register number; that + ;; register has the destination base address for the frame. The stack + ;; pointer is reset to the top end of the copied area. + (LAP ,@(case frame-size + ((0) + (LAP)) + ((1) + (let ((temp (standard-temporary!))) + (LAP (LD ,temp (OFFSET 0 ,regnum:stack-pointer)) + (ADDI ,destination ,destination -4) + (ST ,temp (OFFSET 0 ,destination))))) + (else + (let ((from (standard-temporary!)) + (temp1 (standard-temporary!)) + (temp2 (standard-temporary!))) + (LAP ,@(add-immediate (* 4 frame-size) regnum:stack-pointer from) + ,@(if (<= frame-size 3) + ;; This code can handle any number > 1 + ;; (handled above), but we restrict it to 3 + ;; for space reasons. + (let loop ((n frame-size)) + (case n + ((0) + (LAP)) + ((3) + (let ((temp3 (standard-temporary!))) + (LAP (LD ,temp1 (OFFSET -4 ,from)) + (LD ,temp2 (OFFSET -8 ,from)) + (LD ,temp3 (OFFSET -12 ,from)) + (ADDI ,from ,from -12) + (ST ,temp1 (OFFSET -4 ,destination)) + (ST ,temp2 (OFFSET -8 ,destination)) + (ST ,temp3 (OFFSET -12 ,destination)) + (ADDI ,destination ,destination -12)))) + (else + (LAP (LD ,temp1 (OFFSET -4 ,from)) + (LD ,temp2 (OFFSET -8 ,from)) + (ADDI ,from ,from -8) + (ST ,temp1 (OFFSET -4 ,destination)) + (ST ,temp2 (OFFSET -8 ,destination)) + (ADDI ,destination ,destination -8) + ,@(loop (- n 2)))))) + (let ((label (generate-label))) + (LAP ,@(load-immediate temp2 frame-size #F) + (LABEL ,label) + (LD ,temp1 (OFFSET -4 ,from)) + (ADDI ,from ,from -4) + (ADDI ,temp2 ,temp2 -1) + (ADDI ,destination ,destination -4) + (BNE ,temp2 0 (@PCR ,label)) + (ST ,temp1 (OFFSET 0 ,destination))))))))) + (ADD ,regnum:stack-pointer 0 ,destination))) + +;;;; 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) + (ADD ,regnum:third-arg 0 ,regnum:dynamic-link) + ,@(link-to-interface code:compiler-interrupt-dlink) + ,@(make-external-label code-word label) + ,@(interrupt-check gc-label)))) + +(define (interrupt-check gc-label) + (LAP (SUBCC ,regnum:assembler-temp ,regnum:memtop ,regnum:free) + (BGE (@PCR ,gc-label)) + (LD ,regnum:memtop ,reg:memtop) + )) + +(define-rule statement + (CONTINUATION-ENTRY (? internal-label)) + (make-external-label (continuation-code-word internal-label) + internal-label)) + +(define-rule statement + (CONTINUATION-HEADER (? internal-label)) + (simple-procedure-header (continuation-code-word internal-label) + internal-label + code:compiler-interrupt-continuation)) + +(define-rule statement + (IC-PROCEDURE-HEADER (? internal-label)) + (let ((procedure (label->object internal-label))) + (let ((external-label (rtl-procedure/external-label procedure))) + (LAP (ENTRY-POINT ,external-label) + (EQUATE ,external-label ,internal-label) + ,@(simple-procedure-header expression-code-word + internal-label + code:compiler-interrupt-ic-procedure))))) + +(define-rule statement + (OPEN-PROCEDURE-HEADER (? internal-label)) + (let ((rtl-proc (label->object internal-label))) + (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label) + ,@((if (rtl-procedure/dynamic-link? rtl-proc) + dlink-procedure-header + (lambda (code-word label) + (simple-procedure-header code-word label + code:compiler-interrupt-procedure))) + (internal-procedure-code-word rtl-proc) + internal-label)))) + +(define-rule statement + (PROCEDURE-HEADER (? internal-label) (? min) (? max)) + (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label)) + ,internal-label) + ,@(simple-procedure-header (make-procedure-code-word min max) + internal-label + code:compiler-interrupt-procedure))) + +;;;; Closures. + +;; Magic for compiled entries. + +(define-rule statement + (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) + entry ; ignored -- non-RISCs only + (if (zero? nentries) + (error "Closure header for closure with no entries!" + internal-label)) + (let ((rtl-proc (label->object internal-label))) + (let ((gc-label (generate-label)) + (external-label (rtl-procedure/external-label rtl-proc))) + (LAP (LABEL ,gc-label) + ,@(invoke-interface code:compiler-interrupt-closure) + ,@(make-external-label + (internal-procedure-code-word rtl-proc) + external-label) + (ADDI ,regnum:assembler-temp ,regnum:assembler-temp -12) + ;; Code below here corresponds to code and count in cmpint2.h + ,@(fluid-let ((*register-map* *register-map*)) + (let ((temporary (standard-temporary!))) + ;; Don't cache type constant here, because it won't be + ;; in the register if the closure is entered from the + ;; internal label. + (LAP + (ADDI ,temporary ,regnum:assembler-temp 0) + ,@(put-type (ucode-type compiled-entry) temporary) + (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4) + (ST ,temporary (OFFSET 0 ,regnum:stack-pointer)) + (NOP)))) + (LABEL ,internal-label) + ,@(interrupt-check gc-label))))) + +(define (build-gc-offset-word offset code-word) + (let ((encoded-offset (quotient offset 2))) + (if (eq? endianness 'LITTLE) + (+ (* encoded-offset #x10000) code-word) + (+ (* code-word #x10000) encoded-offset)))) + +(define (closure-bump-size nentries nvars) + (* (* 4 closure-entry-size) + (1+ (quotient (+ (+ nvars (-1+ (* closure-entry-size nentries))) + (-1+ closure-entry-size)) + closure-entry-size)))) + +(define (closure-test-size nentries nvars) + (* 4 + (+ nvars + (-1+ (* nentries closure-entry-size))))) + +(define (cons-closure target label min max nvars) + + ;; Invoke an out-of-line handler to set up the closure's entry point. + ;; Arguments: + ;; - C_arg1: "Return address" + ;; - C_arg2: Delta from header data to real closure code + ;; - C_arg3: Closure size in bytes + ;; After jumping to the out of line handler, the return address should + ;; point to the header data. + ;; Returns closure in regnum:second-arg + + (need-register! regnum:first-arg) + (need-register! regnum:second-arg) + (need-register! regnum:third-arg) + (need-register! regnum:fourth-arg) + (let* ((label-arg (generate-label)) + (dest (standard-target! target))) + (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -108) + (ADDI ,regnum:second-arg 0 (- ,(rtl-procedure/external-label (label->object label)) + ,label-arg)) + (ADDI ,regnum:third-arg 0 ,(+ 20 (* nvars 4))) + (JMPL ,regnum:first-arg ,regnum:assembler-temp 0) + (ADDI ,regnum:first-arg ,regnum:first-arg 8) + (LABEL ,label-arg) + (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure) + (+ closure-entry-size nvars))) + (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max))) + (ADDI ,dest ,regnum:second-arg 0) + )) + ) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? nvars))) + (cons-closure target procedure-label min max nvars)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-MULTICLOSURE (? nentries) (? nvars) (? entries))) + ;; entries is a vector of all the entry points + (case nentries + ((0) + (let ((dest (standard-target! target)) + (temp (standard-temporary!))) + (LAP (ADD ,dest 0 ,regnum:free) + ,@(load-immediate + temp + (make-non-pointer-literal (ucode-type manifest-vector) nvars) + #T) + (ST ,temp (OFFSET 0 ,regnum:free)) + (ADDI ,regnum:free ,regnum:free ,(* 4 (+ nvars 1)))))) + ((1) + (let ((entry (vector-ref entries 0))) + (cons-closure target (car entry) (cadr entry) (caddr entry) nvars))) + (else + (cons-multiclosure target nentries nvars (vector->list entries))))) + +(define (cons-multiclosure target nentries nvars entries) + ;; Invoke an out-of-line handler to set up the closure's entry points. + ;; Arguments: + ;; - C_arg1: Linkage address + ;; - C_arg2: Number of entries + ;; - C_arg3: Number of bytes taken up by closures + + ;; C_arg1 points to a manifest closure header word, followed by + ;; nentries two-word structures, followed by the actual + ;; instructions to return to. + ;; The first word of each descriptor is the format+gc-offset word of + ;; the corresponding entry point of the generated closure. + ;; The second word is the PC-relative JAL instruction. + ;; It is transformed into an absolute instruction by adding the shifted + ;; "return address". + ;; Returns closure in regnum:second-arg. + (rtl-target:=machine-register! target regnum:second-arg) + (require-register! regnum:first-arg) + (require-register! regnum:second-arg) + (require-register! regnum:third-arg) + (require-register! regnum:fourth-arg) + (let ((label-arg (generate-label)) + (dest (standard-target! target))) + (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -256) + (ADDI ,regnum:second-arg 0 ,nentries) + (ADDI ,regnum:third-arg ,regnum:free 0) + (JMPL ,regnum:first-arg ,regnum:assembler-temp 0) + (ADDI ,regnum:first-arg ,regnum:first-arg 8) + (LABEL ,label-arg) + (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure) + (+ 1 + (* nentries closure-entry-size) + nvars))) + ,@(let expand ((offset 12) (entries entries)) + (if (null? entries) + (LAP) + (let ((entry (car entries))) + (LAP + (LONG U ,(build-gc-offset-word + offset + (make-procedure-code-word (cadr entry) + (caddr entry)))) + (LONG U (- ,(rtl-procedure/external-label (label->object (car entry))) + ,label-arg)) + ,@(expand (+ offset (* 4 closure-entry-size)) + (cdr entries)))))) + (ADDI ,dest ,regnum:free 12) + (ADDI ,regnum:free ,regnum:free ,(* (+ (* nentries closure-entry-size) 2 nvars) 4)) + ))) + +;;;; Entry Header +;;; This is invoked by the top level of the LAP generator. + +(define (generate/quotation-header environment-label free-ref-label n-sections) + ;; Calls the linker + ;; On SPARC, regnum:first-arg is used as a temporary here since + ;; load-pc-relative-address uses the assembler temporary. + (in-assembler-environment (empty-register-map) + (list regnum:first-arg regnum:second-arg + regnum:third-arg regnum:fourth-arg) + (lambda () + (let* ((i1 + (load-pc-relative-address regnum:second-arg + 'CONSTANT environment-label)) + (i2 (load-pc-relative-address regnum:second-arg + 'CODE *block-label*)) + (i3 (load-pc-relative-address regnum:third-arg + 'CONSTANT free-ref-label))) + (LAP (LD ,regnum:first-arg ,reg:environment) + ,@i1 + (ST ,regnum:first-arg (OFFSET 0 ,regnum:second-arg)) + ,@i2 + ,@i3 + ,@(load-immediate regnum:fourth-arg n-sections #F) + ,@(link-to-interface code:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label))))))) + +(define (generate/remote-link code-block-label + environment-offset + free-ref-offset + n-sections) + ;; Link all of the top level procedures within the file + (in-assembler-environment (empty-register-map) + (list regnum:first-arg regnum:second-arg + regnum:third-arg regnum:fourth-arg) + (lambda () + (let ((i1 (load-pc-relative regnum:second-arg 'CODE code-block-label false))) + (LAP ,@i1 + (LD ,regnum:fourth-arg ,reg:environment) + ,@(object->address regnum:second-arg regnum:second-arg) + ,@(add-immediate environment-offset regnum:second-arg regnum:first-arg) + (ST ,regnum:fourth-arg (OFFSET 0 ,regnum:first-arg)) + ,@(add-immediate free-ref-offset regnum:second-arg regnum:third-arg) + ,@(load-immediate regnum:fourth-arg n-sections #F) + ,@(link-to-interface code:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label))))))) + +(define (in-assembler-environment map needed-registers thunk) + (fluid-let ((*register-map* map) + (*prefix-instructions* (LAP)) + (*suffix-instructions* (LAP)) + (*needed-registers* needed-registers)) + (let ((instructions (thunk))) + (LAP ,@*prefix-instructions* + ,@instructions + ,@*suffix-instructions*)))) + +(define (generate/constants-block constants references assignments uuo-links + global-links static-vars) + (let ((constant-info + (declare-constants 0 (transmogrifly uuo-links) + (declare-constants 1 references + (declare-constants 2 assignments + (declare-constants 3 (transmogrifly global-links) + (declare-constants false + (map (lambda (pair) + (cons false (cdr pair))) + static-vars) + (declare-constants false constants + (cons false (LAP)))))))))) + (let ((free-ref-label (car constant-info)) + (constants-code (cdr constant-info)) + (debugging-information-label (allocate-constant-label)) + (environment-label (allocate-constant-label)) + (n-sections + (+ (if (null? uuo-links) 0 1) + (if (null? references) 0 1) + (if (null? assignments) 0 1) + (if (null? global-links) 0 1)))) + (values + (LAP ,@constants-code + ;; Place holder for the debugging info filename + (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO) + ;; Place holder for the load time environment if needed + (SCHEME-OBJECT ,environment-label + ,(if (null? free-ref-label) 0 'ENVIRONMENT))) + environment-label + free-ref-label + n-sections)))) + +(define (declare-constants tag constants info) + (define (inner constants) + (if (null? constants) + (cdr info) + (let ((entry (car constants))) + (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry)) + ,@(inner (cdr constants)))))) + (if (and tag (not (null? constants))) + (let ((label (allocate-constant-label))) + (cons label + (inner + `((,(let ((datum (length constants))) + (if (> datum #xffff) + (error "datum too large" datum)) + (+ (* tag #x10000) datum)) + . ,label) + ,@constants)))) + (cons (car info) (inner constants)))) + +(define (transmogrifly uuos) + (define (inner name assoc) + (if (null? assoc) + (transmogrifly (cdr uuos)) + ; produces ((name . label) (0 . label) ... (frame-size . label) ...) + ; where the (0 . label) is repeated to fill out the size required + ; as specified in machin.scm + `((,name . ,(cdar assoc)) ; uuo-label + ,@(let loop ((count (max 0 (- execute-cache-size 2)))) + (if (= count 0) + '() + (cons `(0 . ,(allocate-constant-label)) + (loop (- count 1))))) + (,(caar assoc) . ; frame-size + ,(allocate-constant-label)) + ,@(inner name (cdr assoc))))) + (if (null? uuos) + '() + ;; caar is name, cdar is alist of frame sizes + (inner (caar uuos) (cdar uuos)))) +#| +(define (cons-closure target label min max nvars) + ;; Invoke an out-of-line handler to set up the closure's entry point. + ;; Arguments: + ;; - GR31: "Return address" + ;; GR31 points to a manifest closure header word, followed by a + ;; two-word closure descriptor, followed by the actual + ;; instructions to return to. + ;; The first word of the descriptor is the format+gc-offset word of + ;; the generated closure. + ;; The second word is the PC-relative JAL instruction. + ;; It is transformed into an absolute instruction by adding the shifted + ;; "return address". + ;; - GR4: Value to compare to closure free. + ;; - GR5: Increment for closure free. + ;; Returns closure in regnum:first-arg (GR4) + (rtl-target:=machine-register! target regnum:first-arg) + (require-register! regnum:first-arg) + (require-register! regnum:second-arg) + (require-register! regnum:third-arg) + (require-register! regnum:fourth-arg) + (let ((label-arg (generate-label))) + (LAP (ADDI ,regnum:second-arg ,regnum:scheme-to-interface -72) + (ADDI ,regnum:first-arg ,regnum:closure-free + ,(closure-test-size 1 nvars)) + (JALR 31 ,regnum:second-arg) + (ADDI ,regnum:second-arg 0 ,(closure-bump-size 1 nvars)) + (LABEL ,label-arg) + (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure) + (+ closure-entry-size nvars))) + (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max))) + (LONG U + (+ #x0c000000 ; JAL opcode + (/ (- ,(rtl-procedure/external-label (label->object label)) + ,label-arg) + 4)))))) +|# + + + +;;; Local Variables: *** +;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** +;;; End: *** diff --git a/v7/src/compiler/machines/sparc/rules4.scm b/v7/src/compiler/machines/sparc/rules4.scm new file mode 100644 index 000000000..6bd1bb5ee --- /dev/null +++ b/v7/src/compiler/machines/sparc/rules4.scm @@ -0,0 +1,100 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rules4.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1988-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Interpreter Calls + +(declare (usual-integrations)) + +;;;; Interpreter Calls + +(define-rule statement + (INTERPRETER-CALL:ACCESS (? environment register-expression) (? name)) + (lookup-call code:compiler-access environment name)) + +(define-rule statement + (INTERPRETER-CALL:LOOKUP (? environment register-expression) + (? name) + (? safe?)) + (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup) + environment + name)) + +(define-rule statement + (INTERPRETER-CALL:UNASSIGNED? (? environment register-expression) (? name)) + (lookup-call code:compiler-unassigned? environment name)) + +(define-rule statement + (INTERPRETER-CALL:UNBOUND? (? environment register-expression) (? name)) + (lookup-call code:compiler-unbound? environment name)) + +(define (lookup-call code environment name) + (LAP ,@(load-interface-args! false environment false false) + ,@(load-constant regnum:third-arg name #F #F) + ,@(link-to-interface code))) + +(define-rule statement + (INTERPRETER-CALL:DEFINE (? environment register-expression) + (? name) + (? value register-expression)) + (assignment-call code:compiler-define environment name value)) + +(define-rule statement + (INTERPRETER-CALL:SET! (? environment register-expression) + (? name) + (? value register-expression)) + (assignment-call code:compiler-set! environment name value)) + +(define (assignment-call code environment name value) + (LAP ,@(load-interface-args! false environment false value) + ,@(load-constant regnum:third-arg name #F #F) + ,@(link-to-interface code))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-REFERENCE (REGISTER (? extension)) (? safe?)) + (LAP ,@(load-interface-args! false extension false false) + ,@(link-to-interface + (if safe? + code:compiler-safe-reference-trap + code:compiler-reference-trap)))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-ASSIGNMENT (REGISTER (? extension)) + (? value register-expression)) + (LAP ,@(load-interface-args! false extension value false) + ,@(link-to-interface code:compiler-assignment-trap))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-UNASSIGNED? (REGISTER (? extension))) + (LAP ,@(load-interface-args! false extension false false) + ,@(link-to-interface code:compiler-unassigned?-trap))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/rulfix.scm b/v7/src/compiler/machines/sparc/rulfix.scm new file mode 100644 index 000000000..277177ff0 --- /dev/null +++ b/v7/src/compiler/machines/sparc/rulfix.scm @@ -0,0 +1,565 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rulfix.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1989-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Fixnum Rules +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Conversions + +(define-rule statement + ;; convert a fixnum object to a "fixnum integer" + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source)))) + (standard-unary-conversion source target object->fixnum)) + +(define-rule statement + ;; load a fixnum constant as a "fixnum integer" + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant)))) + (load-immediate (standard-target! target) (* constant fixnum-1) #T)) + +(define-rule statement + ;; convert a memory address to a "fixnum integer" + (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source)))) + (standard-unary-conversion source target address->fixnum)) + +(define-rule statement + ;; convert an object's address to a "fixnum integer" + (ASSIGN (REGISTER (? target)) + (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source))))) + (standard-unary-conversion source target object->fixnum)) + +(define-rule statement + ;; convert a "fixnum integer" to a fixnum object + (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source)))) + (standard-unary-conversion source target fixnum->object)) + +(define-rule statement + ;; convert a "fixnum integer" to a memory address + (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source)))) + (standard-unary-conversion source target fixnum->address)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (OBJECT->FIXNUM (CONSTANT 4)) + (OBJECT->FIXNUM (REGISTER (? source))) + #F)) + (standard-unary-conversion source target object->index-fixnum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (OBJECT->FIXNUM (REGISTER (? source))) + (OBJECT->FIXNUM (CONSTANT 4)) + #F)) + (standard-unary-conversion source target object->index-fixnum)) + +;; This is a patch for the time being. Probably only one of these pairs +;; of rules is needed. + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (OBJECT->FIXNUM (CONSTANT 4)) + (REGISTER (? source)) + #F)) + (standard-unary-conversion source target fixnum->index-fixnum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (REGISTER (? source)) + (OBJECT->FIXNUM (CONSTANT 4)) + #F)) + (standard-unary-conversion source target fixnum->index-fixnum)) + +;; "Fixnum" in this context means an integer left shifted so that +;; the sign bit is the leftmost bit of the word, i.e., the datum +;; has been left shifted by scheme-type-width bits. + +(define-integrable (fixnum->index-fixnum src tgt) + ; Shift left 2 bits + (LAP (SLL ,tgt ,src 2))) + +(define-integrable (object->fixnum src tgt) + ; Shift left by scheme-type-width + (LAP (SLL ,tgt ,src ,scheme-type-width))) + +(define-integrable (object->index-fixnum src tgt) + ; Shift left by scheme-type-width+2 + (LAP (SLL ,tgt ,src ,(+ scheme-type-width 2)))) + +(define-integrable (address->fixnum src tgt) + ; Strip off type bits, just like object->fixnum + (LAP (SLL ,tgt ,src ,scheme-type-width))) + +(define-integrable (fixnum->object src tgt) + ; Move right by type code width and put on fixnum type code + (LAP (SRL ,tgt ,src ,scheme-type-width) + ,@(deposit-type-datum (ucode-type fixnum) tgt tgt))) + +(define (fixnum->address src tgt) + ; Move right by type code width and put in address bits + (LAP (SRL ,tgt ,src ,scheme-type-width) + (OR ,tgt ,tgt ,regnum:quad-bits))) + +(define-integrable fixnum-1 + (expt 2 scheme-type-width)) + +(define-integrable -fixnum-1 + (- fixnum-1)) + +(define (no-overflow-branches!) + (set-current-branches! + (lambda (if-overflow) + if-overflow + (LAP)) + (lambda (if-no-overflow) + (LAP (BA (@PCR ,if-no-overflow)) + (NOP))))) + +(define (guarantee-signed-fixnum n) + (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n)) + n) + +(define (signed-fixnum? n) + (and (exact-integer? n) + (>= n signed-fixnum/lower-limit) + (< n signed-fixnum/upper-limit))) + +;;;; Arithmetic Operations + +(define-rule statement + ;; execute a unary fixnum operation + (ASSIGN (REGISTER (? target)) + (FIXNUM-1-ARG (? operation) + (REGISTER (? source)) + (? overflow?))) + (standard-unary-conversion source target + (lambda (source target) + ((fixnum-1-arg/operator operation) target source overflow?)))) + +(define (fixnum-1-arg/operator operation) + (lookup-arithmetic-method operation fixnum-methods/1-arg)) + +(define fixnum-methods/1-arg + (list 'FIXNUM-METHODS/1-ARG)) + +(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg + (lambda (tgt src overflow?) + (fixnum-add-constant tgt src 1 overflow?))) + +(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg + (lambda (tgt src overflow?) + (fixnum-add-constant tgt src -1 overflow?))) + +(define (fixnum-add-constant tgt src constant overflow?) + (let ((constant (* fixnum-1 constant))) + (cond ((not overflow?) + (add-immediate constant src tgt)) + ((= constant 0) + (no-overflow-branches!) + (LAP (ADDIU ,tgt ,src 0))) + (else + (let ((bcc (if (> constant 0) 'BLE 'BGE))) + (let ((prefix + (if (fits-in-16-bits-signed? constant) + (lambda (label) + (LAP (SUBCCI ,regnum:assembler-temp 0 ,src) + (,bcc ,regnum:assembler-temp (@PCR ,label)) + (ADDIU ,tgt ,src ,constant))) + (with-values (lambda () (immediate->register constant)) + (lambda (prefix alias) + (lambda (label) + (LAP ,@prefix + (,bcc ,src (@PCR ,label)) + (ADDU ,tgt ,src ,alias)))))))) + (if (> constant 0) + (set-current-branches! + (lambda (if-overflow) + (let ((if-no-overflow (generate-label))) + (LAP ,@(prefix if-no-overflow) + (SUBCCI ,regnum:assembler-temp 0 ,tgt) + (BLT ,tgt (@PCR ,if-overflow)) + (NOP) + (LABEL ,if-no-overflow)))) + (lambda (if-no-overflow) + (LAP ,@(prefix if-no-overflow) + (SUBCCI ,regnum:assembler-temp 0 ,tgt) + (BGE ,tgt (@PCR ,if-no-overflow)) + (NOP)))) + (set-current-branches! + (lambda (if-overflow) + (let ((if-no-overflow (generate-label))) + (LAP ,@(prefix if-no-overflow) + (SUBCCI ,regnum:assembler-temp 0 ,tgt) + (BGE ,tgt (@PCR ,if-overflow)) + (NOP) + (LABEL ,if-no-overflow)))) + (lambda (if-no-overflow) + (LAP ,@(prefix if-no-overflow) + (BLTZ ,tgt (@PCR ,if-no-overflow)) + (NOP))))))) + (LAP))))) + +(define-rule statement + ;; execute a binary fixnum operation + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + (standard-binary-conversion source1 source2 target + (lambda (source1 source2 target) + ((fixnum-2-args/operator operation) target source1 source2 overflow?)))) + +(define (fixnum-2-args/operator operation) + (lookup-arithmetic-method operation fixnum-methods/2-args)) + +(define fixnum-methods/2-args + (list 'FIXNUM-METHODS/2-ARGS)) + +(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (if overflow? + (do-overflow-addition tgt src1 src2) + (LAP (ADDU ,tgt ,src1 ,src2))))) + +;;; Use of REGNUM:ASSEMBLER-TEMP is OK here, but only because its +;;; value is not used after the branch instruction that tests it. +;;; The long form of the @PCR branch will test it correctly, but +;;; clobbers it after testing. + +(define (do-overflow-addition tgt src1 src2) + (cond ((not (= src1 src2)) + (set-current-branches! + (lambda (if-overflow) + (let ((if-no-overflow (generate-label))) + (LAP (XOR ,regnum:assembler-temp ,src1 ,src2) + (BLTZ ,regnum:assembler-temp (@PCR ,if-no-overflow)) + (ADDU ,tgt ,src1 ,src2) + (XOR ,regnum:assembler-temp + ,tgt + ,(if (= tgt src1) src2 src1)) + (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow)) + (NOP) + (LABEL ,if-no-overflow)))) + (lambda (if-no-overflow) + (LAP (XOR ,regnum:assembler-temp ,src1 ,src2) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BLT ,regnum:assembler-temp (@PCR ,if-no-overflow)) + (ADDU ,tgt ,src1 ,src2) + (XOR ,regnum:assembler-temp + ,tgt + ,(if (= tgt src1) src2 src1)) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow)) + (NOP))))) + ((not (= tgt src1)) + (set-current-branches! + (lambda (if-overflow) + (LAP (ADDU ,tgt ,src1 ,src1) + (XOR ,regnum:assembler-temp ,tgt ,src1) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BLT ,regnum:assembler-temp (@PCR ,if-overflow)) + (NOP))) + (lambda (if-no-overflow) + (LAP (ADDU ,tgt ,src1 ,src1) + (XOR ,regnum:assembler-temp ,tgt ,src1) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow)) + (NOP))))) + (else + (let ((temp (standard-temporary!))) + (set-current-branches! + (lambda (if-overflow) + (LAP (ADDU ,temp ,src1 ,src1) + (XOR ,regnum:assembler-temp ,temp ,src1) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BLT ,regnum:assembler-temp (@PCR ,if-overflow)) + (ADD ,tgt 0 ,temp))) + (lambda (if-no-overflow) + (LAP (ADDU ,temp ,src1 ,src1) + (XOR ,regnum:assembler-temp ,temp ,src1) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow)) + (ADD ,tgt 0 ,temp))))))) + (LAP)) + +(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (if overflow? + (if (= src1 src2) ;probably won't ever happen. + (begin + (no-overflow-branches!) + (LAP (SUBU ,tgt ,src1 ,src1))) + (do-overflow-subtraction tgt src1 src2)) + (LAP (SUB ,tgt ,src1 ,src2))))) + +(define (do-overflow-subtraction tgt src1 src2) + (set-current-branches! + (lambda (if-overflow) + (let ((if-no-overflow (generate-label))) + (LAP (XOR ,regnum:assembler-temp ,src1 ,src2) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow)) + (SUBU ,tgt ,src1 ,src2) + ,@(if (not (= tgt src1)) + (LAP (XOR ,regnum:assembler-temp ,tgt ,src1) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BLT ,regnum:assembler-temp (@PCR ,if-overflow))) + (LAP (XOR ,regnum:assembler-temp ,tgt ,src2) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BGE ,regnum:assembler-temp (@PCR ,if-overflow)))) + (NOP) + (LABEL ,if-no-overflow)))) + (lambda (if-no-overflow) + (LAP (XOR ,regnum:assembler-temp ,src1 ,src2) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow)) + (SUBU ,tgt ,src1 ,src2) + ,@(if (not (= tgt src1)) + (LAP (XOR ,regnum:assembler-temp ,tgt ,src1) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0) + (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))) + (LAP (XOR ,regnum:assembler-temp ,tgt ,src2) + (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0g) + (BLT ,regnum:assembler-temp (@PCR ,if-no-overflow)))) + (NOP)))) + (LAP)) + +(define (do-multiply tgt src1 src2 overflow?) + (if overflow? + (let ((temp (standard-temporary!))) + (set-current-branches! + (lambda (if-overflow) + (LAP (MFHI ,temp) + (SRA ,regnum:assembler-temp ,tgt 31) + (BNE ,temp ,regnum:assembler-temp + (@PCR ,if-overflow)) + (NOP))) + (lambda (if-no-overflow) + (LAP (MFHI ,temp) + (SRA ,regnum:assembler-temp ,tgt 31) + (BEQ ,temp ,regnum:assembler-temp + (@PCR ,if-no-overflow)) + (NOP)))))) + (LAP (SRA ,regnum:assembler-temp ,src1 ,scheme-type-width) + (MULT ,regnum:assembler-temp ,src2) + (MFLO ,tgt))) + +(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args do-multiply) + +(define-rule statement + ;; execute binary fixnum operation with constant second arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source)) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (? overflow?))) + (standard-unary-conversion source target + (lambda (source target) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?)))) + +(define-rule statement + ;; execute binary fixnum operation with constant first arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (REGISTER (? source)) + (? overflow?))) + (standard-unary-conversion source target + (lambda (source target) + (if (fixnum-2-args/commutative? operation) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?) + ((fixnum-2-args/operator/constant*register operation) + target constant source overflow?))))) + +(define (fixnum-2-args/commutative? operator) + (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM))) + +(define (fixnum-2-args/operator/register*constant operation) + (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant)) + +(define fixnum-methods/2-args/register*constant + (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT)) + +(define (fixnum-2-args/operator/constant*register operation) + (lookup-arithmetic-method operation + fixnum-methods/2-args/constant*register)) + +(define fixnum-methods/2-args/constant*register + (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER)) + +(define-arithmetic-method 'PLUS-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (fixnum-add-constant tgt src constant overflow?))) + +(define-arithmetic-method 'MINUS-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (fixnum-add-constant tgt src (- constant) overflow?))) + +(define-arithmetic-method 'MULTIPLY-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (cond ((zero? constant) + (if overflow? (no-overflow-branches!)) + (LAP (ADDI ,tgt 0 0))) + ((= constant 1) + (if overflow? (no-overflow-branches!)) + (LAP (ADD ,tgt 0 ,src))) + ((let loop ((n constant)) + (and (> n 0) + (if (= n 1) + 0 + (and (even? n) + (let ((m (loop (quotient n 2)))) + (and m + (+ m 1))))))) + => + (lambda (power-of-two) + (if overflow? + (do-left-shift-overflow tgt src power-of-two) + (LAP (SLL ,tgt ,src ,power-of-two))))) + (else + (with-values (lambda () (immediate->register (* constant fixnum-1))) + (lambda (prefix alias) + (LAP ,@prefix + ,@(do-multiply tgt src alias overflow?)))))))) + +(define (do-left-shift-overflow tgt src power-of-two) + (if (= tgt src) + (let ((temp (standard-temporary!))) + (set-current-branches! + (lambda (if-overflow) + (LAP (SLL ,temp ,src ,power-of-two) + (SRA ,regnum:assembler-temp ,temp ,power-of-two) + (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow)) + (ADD ,tgt 0 ,temp))) + (lambda (if-no-overflow) + (LAP (SLL ,temp ,src ,power-of-two) + (SRA ,regnum:assembler-temp ,temp ,power-of-two) + (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow)) + (ADD ,tgt 0 ,temp))))) + (set-current-branches! + (lambda (if-overflow) + (LAP (SLL ,tgt ,src ,power-of-two) + (SRA ,regnum:assembler-temp ,tgt ,power-of-two) + (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow)) + (NOP))) + (lambda (if-no-overflow) + (LAP (SLL ,tgt ,src ,power-of-two) + (SRA ,regnum:assembler-temp ,tgt ,power-of-two) + (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow)) + (NOP))))) + (LAP)) + +(define-arithmetic-method 'MINUS-FIXNUM + fixnum-methods/2-args/constant*register + (lambda (tgt constant src overflow?) + (guarantee-signed-fixnum constant) + (with-values (lambda () (immediate->register (* constant fixnum-1))) + (lambda (prefix alias) + (LAP ,@prefix + ,@(if overflow? + (do-overflow-subtraction tgt alias src) + (LAP (SUB ,tgt ,alias ,src)))))))) + +;;;; Predicates + +(define-rule predicate + (OVERFLOW-TEST) + ;; The RTL code generate guarantees that this instruction is always + ;; immediately preceded by a fixnum operation with the OVERFLOW? + ;; flag turned on. Furthermore, it also guarantees that there are + ;; no other fixnum operations with the OVERFLOW? flag set. So all + ;; the processing of overflow tests has been moved into the fixnum + ;; operations. + (LAP)) + +(define-rule predicate + (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source))) + (compare-immediate (fixnum-pred-1->cc predicate) + 0 + (standard-source! source))) + +(define (fixnum-pred-1->cc predicate) + (case predicate + ((ZERO-FIXNUM?) '=) + ((NEGATIVE-FIXNUM?) '>) + ((POSITIVE-FIXNUM?) '<) + (else (error "unknown fixnum predicate" predicate)))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (compare (fixnum-pred-2->cc predicate) + (standard-source! source1) + (standard-source! source2))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (REGISTER (? source)) + (OBJECT->FIXNUM (CONSTANT (? constant)))) + (compare-fixnum/constant*register (invert-condition-noncommutative + (fixnum-pred-2->cc predicate)) + constant + (standard-source! source))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (REGISTER (? source))) + (compare-fixnum/constant*register (fixnum-pred-2->cc predicate) + constant + (standard-source! source))) + +(define-integrable (compare-fixnum/constant*register cc n r) + (guarantee-signed-fixnum n) + (compare-immediate cc (* n fixnum-1) r)) + +(define (fixnum-pred-2->cc predicate) + (case predicate + ((EQUAL-FIXNUM?) '=) + ((LESS-THAN-FIXNUM?) '<) + ((GREATER-THAN-FIXNUM?) '>) + (else (error "unknown fixnum predicate" predicate)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/rulflo.scm b/v7/src/compiler/machines/sparc/rulflo.scm new file mode 100644 index 000000000..638d54aa3 --- /dev/null +++ b/v7/src/compiler/machines/sparc/rulflo.scm @@ -0,0 +1,172 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rulflo.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ + +Copyright (c) 1989-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Flonum rules + +(declare (usual-integrations)) + +(define (flonum-source! register) + (float-register->fpr (load-alias-register! register 'FLOAT))) + +(define (flonum-target! pseudo-register) + (delete-dead-registers!) + (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT))) + +(define (flonum-temporary!) + (float-register->fpr (allocate-temporary-register! 'FLOAT))) + +(define-rule statement + ;; convert a floating-point number to a flonum object + (ASSIGN (REGISTER (? target)) + (FLOAT->OBJECT (REGISTER (? source)))) + (let ((source (fpr->float-register (flonum-source! source)))) + (let ((target (standard-target! target))) + (LAP + ; (SW 0 (OFFSET 0 ,regnum:free)) ; make heap parsable forwards + (ORI ,regnum:free ,regnum:free #b100) ; Align to odd quad byte + ,@(deposit-type-address (ucode-type flonum) regnum:free target) + ,@(with-values + (lambda () + (immediate->register + (make-non-pointer-literal (ucode-type manifest-nm-vector) 2))) + (lambda (prefix alias) + (LAP ,@prefix + (SW ,alias (OFFSET 0 ,regnum:free))))) + ,@(fp-store-doubleword 4 regnum:free source) + (ADDI ,regnum:free ,regnum:free 12))))) + +(define-rule statement + ;; convert a flonum object to a floating-point number + (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source)))) + (let ((source (standard-move-to-temporary! source))) + (let ((target (fpr->float-register (flonum-target! target)))) + (LAP ,@(object->address source source) + ,@(fp-load-doubleword 4 source target #T))))) + +;;;; Flonum Arithmetic + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?))) + overflow? ;ignore + (let ((source (flonum-source! source))) + ((flonum-1-arg/operator operation) (flonum-target! target) source))) + +(define (flonum-1-arg/operator operation) + (lookup-arithmetic-method operation flonum-methods/1-arg)) + +(define flonum-methods/1-arg + (list 'FLONUM-METHODS/1-ARG)) + +;;; Notice the weird ,', syntax here. +;;; If LAP changes, this may also have to change. + +(let-syntax + ((define-flonum-operation + (macro (primitive-name opcode) + `(define-arithmetic-method ',primitive-name flonum-methods/1-arg + (lambda (target source) + (LAP (,opcode ,',target ,',source))))))) + (define-flonum-operation flonum-abs ABS.D) + (define-flonum-operation flonum-negate NEG.D)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + overflow? ;ignore + (let ((source1 (flonum-source! source1)) + (source2 (flonum-source! source2))) + ((flonum-2-args/operator operation) (flonum-target! target) + source1 + source2))) + +(define (flonum-2-args/operator operation) + (lookup-arithmetic-method operation flonum-methods/2-args)) + +(define flonum-methods/2-args + (list 'FLONUM-METHODS/2-ARGS)) + +(let-syntax + ((define-flonum-operation + (macro (primitive-name opcode) + `(define-arithmetic-method ',primitive-name flonum-methods/2-args + (lambda (target source1 source2) + (LAP (,opcode ,',target ,',source1 ,',source2))))))) + (define-flonum-operation flonum-add ADD.D) + (define-flonum-operation flonum-subtract SUB.D) + (define-flonum-operation flonum-multiply MUL.D) + (define-flonum-operation flonum-divide DIV.D)) + +;;;; Flonum Predicates + +(define-rule predicate + (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source))) + ;; No immediate zeros, easy to generate by subtracting from itself + (let ((temp (flonum-temporary!)) + (source (flonum-source! source))) + (LAP (MTC1 0 ,temp) + (MTC1 0 ,(+ temp 1)) + (NOP) + ,@(flonum-compare + (case predicate + ((FLONUM-ZERO?) 'C.EQ.D) + ((FLONUM-NEGATIVE?) 'C.LT.D) + ((FLONUM-POSITIVE?) 'C.GT.D) + (else (error "unknown flonum predicate" predicate))) + source temp)))) + +(define-rule predicate + (FLONUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (flonum-compare (case predicate + ((FLONUM-EQUAL?) 'C.EQ.D) + ((FLONUM-LESS?) 'C.LT.D) + ((FLONUM-GREATER?) 'C.GT.D) + (else (error "unknown flonum predicate" predicate))) + (flonum-source! source1) + (flonum-source! source2))) + +(define (flonum-compare cc r1 r2) + (set-current-branches! + (lambda (label) + (LAP (BC1T (@PCR ,label)) (NOP))) + (lambda (label) + (LAP (BC1F (@PCR ,label)) (NOP)))) + (if (eq? cc 'C.GT.D) + (LAP (C.LT.D ,r2 ,r1) (NOP)) + (LAP (,cc ,r1 ,r2) (NOP)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/rulrew.scm b/v7/src/compiler/machines/sparc/rulrew.scm new file mode 100644 index 000000000..044945ee6 --- /dev/null +++ b/v7/src/compiler/machines/sparc/rulrew.scm @@ -0,0 +1,216 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/sparc/rulrew.scm,v 1.1 1993/06/08 06:11:02 gjr Exp $ +$MC68020-Header: rulrew.scm,v 1.1 90/01/18 22:48:52 GMT cph Exp $ + +Copyright (c) 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Rewrite Rules + +(declare (usual-integrations)) + +;;;; Synthesized Data +#| +(define-rule rewriting + (CONS-POINTER (REGISTER (? type register-known-value)) + (REGISTER (? datum register-known-value))) + (QUALIFIER (and (rtl:machine-constant? type) + (rtl:machine-constant? datum))) + (rtl:make-cons-pointer type datum)) + +;; I've copied these rules from the MC68020. -- Jinx. + +(define-rule rewriting + (CONS-POINTER (REGISTER (? type register-known-value)) (? datum)) + (QUALIFIER + (and (rtl:object->type? type) + (rtl:constant? (rtl:object->type-expression type)))) + (rtl:make-cons-pointer + (rtl:make-machine-constant + (object-type (rtl:object->type-expression datum))) + datum)) + +(define-rule rewriting + (CONS-POINTER (? type) (REGISTER (? datum register-known-value))) + (QUALIFIER + (and (rtl:object->datum? datum) + (rtl:constant-non-pointer? (rtl:object->datum-expression datum)))) + (rtl:make-cons-pointer + type + (rtl:make-machine-constant + (careful-object-datum (rtl:object->datum-expression datum))))) + +(define-rule rewriting + (OBJECT->TYPE (REGISTER (? source register-known-value))) + (QUALIFIER (rtl:constant? source)) + (rtl:make-machine-constant (object-type (rtl:constant-value source)))) + +(define-rule rewriting + (OBJECT->DATUM (REGISTER (? source register-known-value))) + (QUALIFIER (rtl:constant-non-pointer? source)) + (rtl:make-machine-constant (careful-object-datum source))) + +(define (rtl:constant-non-pointer? expression) + (and (rtl:constant? expression) + (non-pointer-object? (rtl:constant-value expression)))) + +;; I've modified these rules from the MC68020. -- Jinx + +;;; These rules are losers because there's no abstract way to cons a +;;; statement or a predicate without also getting some CFG structure. + +(define-rule rewriting + ;; Use register 0, always 0. + (ASSIGN (? target) (REGISTER (? comparand register-known-value))) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'ASSIGN target (rtl:make-machine-constant 0))) + +(define-rule rewriting + ;; Compare to register 0, always 0. + (EQ-TEST (? source) (REGISTER (? comparand register-known-value))) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'EQ-TEST source (rtl:make-machine-constant 0))) + +(define-rule rewriting + ;; Compare to register 0, always 0. + (EQ-TEST (REGISTER (? comparand register-known-value)) (? source)) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'EQ-TEST source (rtl:make-machine-constant 0))) + +(define (rtl:immediate-zero-constant? expression) + (cond ((rtl:constant? expression) + (let ((value (rtl:constant-value expression))) + (and (non-pointer-object? value) + (zero? (object-type value)) + (zero? (careful-object-datum value))))) + ((rtl:cons-pointer? expression) + (and (let ((expression (rtl:cons-pointer-type expression))) + (and (rtl:machine-constant? expression) + (zero? (rtl:machine-constant-value expression)))) + (let ((expression (rtl:cons-pointer-datum expression))) + (and (rtl:machine-constant? expression) + (zero? (rtl:machine-constant-value expression)))))) + (else false))) + +;;;; Fixnums + +;; I've copied this rule from the MC68020. -- Jinx +;; It should probably be qualified to be in the immediate range. + +(define-rule rewriting + (OBJECT->FIXNUM (REGISTER (? source register-known-value))) + (QUALIFIER (rtl:constant-fixnum? source)) + (rtl:make-object->fixnum source)) + +(define-rule rewriting + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (REGISTER (? operand-1 register-known-value)) + (? operand-2) + #F) + (QUALIFIER (rtl:constant-fixnum-4? operand-1)) + (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F)) + +(define-rule rewriting + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (? operand-1) + (REGISTER (? operand-2 register-known-value)) + #F) + (QUALIFIER (rtl:constant-fixnum-4? operand-2)) + (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F)) + +(define-rule rewriting + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (REGISTER (? operand-1 register-known-value)) + (? operand-2) + #F) + (QUALIFIER + (and (rtl:object->fixnum-of-register? operand-1) + (rtl:constant-fixnum-4? operand-2))) + (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F)) + +(define-rule rewriting + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (? operand-1) + (REGISTER (? operand-2 register-known-value)) + #F) + (QUALIFIER + (and (rtl:constant-fixnum-4? operand-1) + (rtl:object->fixnum-of-register? operand-2))) + (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F)) + +(define (rtl:constant-fixnum? expression) + (and (rtl:constant? expression) + (fix:fixnum? (rtl:constant-value expression)))) + +(define (rtl:constant-fixnum-4? expression) + (and (rtl:object->fixnum? expression) + (let ((expression (rtl:object->fixnum-expression expression))) + (and (rtl:constant? expression) + (eqv? 4 (rtl:constant-value expression)))))) + +(define (rtl:object->fixnum-of-register? expression) + (and (rtl:object->fixnum? expression) + (rtl:register? (rtl:object->fixnum-expression expression)))) + +;;;; Closures and othe optimizations. + +;; These rules are Spectrum specific + +(define-rule rewriting + (CONS-POINTER (REGISTER (? type register-known-value)) + (REGISTER (? datum register-known-value))) + (QUALIFIER (and (rtl:machine-constant? type) + (= (rtl:machine-constant-value type) + (ucode-type compiled-entry)) + (or (rtl:entry:continuation? datum) + (rtl:entry:procedure? datum) + (rtl:cons-closure? datum)))) + (rtl:make-cons-pointer type datum)) +|# + +#| +;; Not yet written. + +;; A type is compatible when a depi instruction can put it in assuming that +;; the datum has the quad bits set. +;; A register is a machine-address-register if it is a machine register and +;; always contains an address (ie. free pointer, stack pointer, or dlink register) + +(define-rule rewriting + (CONS-POINTER (REGISTER (? type register-known-value)) + (REGISTER (? datum machine-address-register))) + (QUALIFIER (and (rtl:machine-constant? type) + (spectrum-type-optimizable? (rtl:machine-constant-value type)))) + (rtl:make-cons-pointer type datum)) +|# + + + \ No newline at end of file diff --git a/v7/src/microcode/cmpauxmd/c.c b/v7/src/microcode/cmpauxmd/c.c new file mode 100644 index 000000000..a5239d713 --- /dev/null +++ b/v7/src/microcode/cmpauxmd/c.c @@ -0,0 +1,421 @@ +/* -*-C-*- + +$Id: c.c,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +#include "liarc.h" +#include "bignum.h" +#include "bitstr.h" + +extern void EXFUN (lose_big_1, (char *, char *)); + +#ifdef BUG_GCC_LONG_CALLS + +extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *)); +extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *)); +extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean)); +extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT)); +extern SCHEME_OBJECT EXFUN (double_to_flonum, (double)); +extern SCHEME_OBJECT EXFUN (long_to_integer, (long)); +extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *)); +extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *)); +extern SCHEME_OBJECT EXFUN (search_for_primitive, + (SCHEME_OBJECT, char *, Boolean, Boolean, int)); + +SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ()) = +{ + ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_string), + ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_symbol), + ((SCHEME_OBJECT EXFUN ((*), ())) make_vector), + ((SCHEME_OBJECT EXFUN ((*), ())) cons), + ((SCHEME_OBJECT EXFUN ((*), ())) rconsm), + ((SCHEME_OBJECT EXFUN ((*), ())) double_to_flonum), + ((SCHEME_OBJECT EXFUN ((*), ())) long_to_integer), + ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_integer), + ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_bit_string), + ((SCHEME_OBJECT EXFUN ((*), ())) search_for_primitive) +}; + +#endif /* BUG_GCC_LONG_CALLS */ + +extern char * interface_to_C_hook; +extern void EXFUN (C_to_interface, (PTR)); +extern void EXFUN (interface_initialize, (void)); +extern SCHEME_OBJECT * EXFUN (initialize_C_compiled_block, (int, char *)); +extern void EXFUN (initialize_compiled_code_blocks, (void)); + +typedef SCHEME_OBJECT * EXFUN ((* compiled_block), (SCHEME_OBJECT *)); + +int pc_zero_bits; +char * interface_to_C_hook; +static compiled_block * compiled_code_blocks; +static char ** compiled_block_names; +static int max_compiled_code_blocks, compiled_code_blocks_size; +static SCHEME_OBJECT dummy_entry = SHARP_F; + +SCHEME_OBJECT * +DEFUN (trampoline_procedure, (trampoline), SCHEME_OBJECT * trampoline) +{ + return (invoke_utility ((LABEL_TAG (trampoline)), + ((long) (TRAMPOLINE_STORAGE (trampoline))), + 0, 0, 0)); +} + +void +DEFUN_VOID (NO_SUBBLOCKS) +{ + return; +} + +int +DEFUN (declare_compiled_code, (name, decl_proc, code_proc), + char * name + AND void EXFUN (decl_proc, (void)) + AND SCHEME_OBJECT * EXFUN (code_proc, (SCHEME_OBJECT *))) +{ + int index; + + index = max_compiled_code_blocks; + max_compiled_code_blocks += 1; + if ((MAKE_LABEL_WORD (index, 0)) == dummy_entry) + return (0); + + if (index >= compiled_code_blocks_size) + { + compiled_block * new_blocks; + char ** new_names; + compiled_code_blocks_size = ((compiled_code_blocks_size == 0) + ? 10 + : (compiled_code_blocks_size * 2)); + new_blocks = + ((compiled_block *) + (realloc (compiled_code_blocks, + (compiled_code_blocks_size * (sizeof (compiled_block)))))); + + new_names = + ((char **) + (realloc (compiled_block_names, + (compiled_code_blocks_size * (sizeof (char *)))))); + + if ((new_blocks == ((compiled_block *) NULL)) + || (new_names == ((char **) NULL))) + return (0); + compiled_code_blocks = new_blocks; + compiled_block_names = new_names; + } + compiled_code_blocks[index] = (code_proc); + compiled_block_names[index] = name; + decl_proc (); + return (index); +} + +void +DEFUN_VOID (interface_initialize) +{ + int i, pow, del; + + for (i = 0, pow = 1, del = ((sizeof (SCHEME_OBJECT)) / (sizeof (char))); + pow < del; + i+= 1) + pow = (pow << 1); + + if (pow != del) + lose_big ("initialize_compiler: not a power of two"); + + pc_zero_bits = i; + + dummy_entry = (MAKE_LABEL_WORD (-1, 0)); + interface_to_C_hook = ((char *) &dummy_entry); + max_compiled_code_blocks = 0; + compiled_code_blocks_size = 0; + compiled_code_blocks = ((compiled_block *) NULL); + compiled_block_names = ((char **) NULL); + (void) declare_compiled_code ("", NO_SUBBLOCKS, trampoline_procedure); + + initialize_compiled_code_blocks (); + + return; +} + +/* For now this is a linear search. + Not that it matters much, but we could easily + make it binary. + */ + +int +DEFUN (find_compiled_block, (name), char * name) +{ + int i; + + for (i = 1; i < max_compiled_code_blocks; i++) + { + if ((strcmp (name, compiled_block_names[i])) == 0) + return (i); + } + return (0); +} + +SCHEME_OBJECT +DEFUN (initialize_subblock, (name), char * name) +{ + SCHEME_OBJECT id, * ep, * block; + int slot = (find_compiled_block (name)); + + if (slot == 0) + error_external_return (); + + id = (MAKE_LABEL_WORD (slot, 0)); + ep = ((* (compiled_code_blocks[slot])) (&id)); + Get_Compiled_Block (block, ep); + return (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block)); +} + +SCHEME_OBJECT * +DEFUN (initialize_C_compiled_block, (argno, name), + int argno AND char * name) +{ + int slot; + SCHEME_OBJECT id; + slot = (find_compiled_block (name)); + if (slot == 0) + return ((SCHEME_OBJECT *) NULL); + + id = (MAKE_LABEL_WORD (slot, 0)); + return ((* (compiled_code_blocks[slot])) (&id)); +} + +void +DEFUN (C_to_interface, (entry), PTR in_entry) +{ + SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) in_entry); + while (1) + { + int proc_index; + proc_index = (LABEL_PROCEDURE (entry)); + if (proc_index >= max_compiled_code_blocks) + { + if (entry != &dummy_entry) +#if 0 + { + /* We need to export C_return_value before enabling this code. */ + Store_Expression ((SCHEME_OBJECT) entry); + C_return_value = (ERR_EXECUTE_MANIFEST_VECTOR); + return; + } +#else + lose_big ("C_to_interface: non-existent procedure"); +#endif + return; + } + else + entry = ((* (compiled_code_blocks [proc_index])) (entry)); + } +} + +typedef SCHEME_OBJECT * EXFUN + ((* utility_table_entry), (long, long, long, long)); + +extern utility_table_entry utility_table[]; + +SCHEME_OBJECT * +DEFUN (invoke_utility, (code, arg1, arg2, arg3, arg4), + int code AND long arg1 AND long arg2 AND long arg3 AND long arg4) +{ + return ((* utility_table[code]) (arg1, arg2, arg3, arg4)); +} + +int +DEFUN (multiply_with_overflow, (x, y, res), long x AND long y AND long * res) +{ + extern SCHEME_OBJECT EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT)); + SCHEME_OBJECT ans; + + ans = (Mul ((LONG_TO_FIXNUM (x)), (LONG_TO_FIXNUM (y)))); + if (ans == SHARP_F) + { + /* Bogus... */ + * res = (x * y); + return (1); + } + else + { + * res = (FIXNUM_TO_LONG (ans)); + return (0); + } +} + +void +DEFUN (lose_big, (msg), char * msg) +{ + fprintf (stderr, "\nlose_big: %s.\n", msg); + Microcode_Termination (TERM_EXIT); + /*NOTREACHED*/ +} + +void +DEFUN (lose_big_1, (msg, arg), char * msg AND char * arg) +{ + fprintf (stderr, "\nlose_big: %s (%s).\n", msg, arg); + Microcode_Termination (TERM_EXIT); + /*NOTREACHED*/ +} + +void +DEFUN_VOID (error_band_already_built) +{ + lose_big ("Trying to initilize data with the wrong binary."); + /*NOTREACHED*/ +} + +/* This avoids consing the string and symbol if it already exists. */ + +SCHEME_OBJECT +DEFUN (memory_to_symbol, (length, string), + long length AND unsigned char * string) +{ + extern SCHEME_OBJECT EXFUN (find_symbol, (long, unsigned char *)); + extern SCHEME_OBJECT EXFUN (string_to_symbol, (SCHEME_OBJECT)); + SCHEME_OBJECT symbol; + + symbol = (find_symbol (length, string)); + if (symbol != SHARP_F) + return (symbol); + return (string_to_symbol (memory_to_string (length, string))); +} + +static unsigned int +DEFUN (hex_digit_to_int, (h_digit), char h_digit) +{ + unsigned int digit = ((unsigned int) h_digit); + + return (((digit >= '0') && (digit <= '9')) + ? (digit - '0') + : (((digit >= 'A') && (digit <= 'F')) + ? ((digit - 'A') + 10) + : ((digit - 'a') + 10))); +} + +static unsigned int +DEFUN (digit_string_producer, (digit_ptr), char ** digit_ptr) +{ + char digit = ** digit_ptr; + * digit_ptr = ((* digit_ptr) + 1); + return (hex_digit_to_int (digit)); +} + +SCHEME_OBJECT +DEFUN (digit_string_to_integer, (negative_p, n_digits, digits), + Boolean negative_p AND long n_digits AND char * digits) +{ + char * digit = digits; + + return (digit_stream_to_bignum (((int) n_digits), + digit_string_producer, + ((PTR) & digit), + 16, + ((int) negative_p))); +} + +SCHEME_OBJECT +DEFUN (digit_string_to_bit_string, (n_bits, n_digits, digits), + long n_bits AND long n_digits AND char * digits) +{ + extern void EXFUN (clear_bit_string, (SCHEME_OBJECT)); + extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long)); + extern void EXFUN (bit_string_set, (SCHEME_OBJECT, long, int)); + SCHEME_OBJECT result = (allocate_bit_string (n_bits)); + unsigned int digit, mask; + long i, posn; + int j; + + posn = 0; + clear_bit_string (result); + + for (i = 0; i < n_digits; i++) + { + digit = (hex_digit_to_int (*digits++)); + for (j = 0, mask = 1; + j < 4; + j++, mask = (mask << 1), posn++) + if ((digit & mask) != 0) + bit_string_set (result, posn, 1); + } + return (result); +} + +#ifdef USE_STDARG + +SCHEME_OBJECT +DEFUN (rconsm, (nargs, tail DOTS), + int nargs AND SCHEME_OBJECT tail DOTS) +{ + va_list arg_ptr; + va_start (arg_ptr, tail); + { + int i; + SCHEME_OBJECT result = tail; + for (i = 1; i < nargs; i++) + result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)), + result)); + + va_end (arg_ptr); + return (result); + } +} + +#else /* not USE_STDARG */ + +SCHEME_OBJECT +rconsm (va_alist) +va_dcl +{ + va_list arg_ptr; + int nargs; + SCHEME_OBJECT tail; + + va_start (arg_ptr); + nargs = (va_arg (arg_ptr, int)); + tail = (va_arg (arg_ptr, SCHEME_OBJECT)); + + { + int i; + SCHEME_OBJECT result = tail; + for (i = 1; i < nargs; i++) + result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)), + result)); + + va_end (arg_ptr); + return (result); + } +} + +#endif /* USE_STDARG */ diff --git a/v7/src/microcode/cmpintmd/c.h b/v7/src/microcode/cmpintmd/c.h new file mode 100644 index 000000000..1c0069c7f --- /dev/null +++ b/v7/src/microcode/cmpintmd/c.h @@ -0,0 +1,243 @@ +/* -*-C-*- + +$Id: c.h,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +#ifndef CMPINT2_H_INCLUDED +#define CMPINT2_H_INCLUDED + +#include "limits.h" + +#define COMPILER_NONE_TYPE 0 +#define COMPILER_MC68020_TYPE 1 +#define COMPILER_VAX_TYPE 2 +#define COMPILER_SPECTRUM_TYPE 3 +#define COMPILER_OLD_MIPS_TYPE 4 +#define COMPILER_MC68040_TYPE 5 +#define COMPILER_SPARC_TYPE 6 +#define COMPILER_RS6000_TYPE 7 +#define COMPILER_MC88K_TYPE 8 +#define COMPILER_I386_TYPE 9 +#define COMPILER_ALPHA_TYPE 10 +#define COMPILER_MIPS_TYPE 11 +#define COMPILER_LOSING_C_TYPE 12 + +#define COMPILER_PROCESSOR_TYPE COMPILER_LOSING_C_TYPE + +#define HALF_OBJECT_LENGTH (OBJECT_LENGTH / 2) +#define HALF_OBJECT_LOW_MASK ((((unsigned long) 1) << HALF_OBJECT_LENGTH) - 1) +#define HALF_OBJECT_HIGH_MASK (HALF_OBJECT_LOW_MASK << HALF_OBJECT_LENGTH) + +#define MAKE_LABEL_WORD(proc_tag,dispatch) \ +((SCHEME_OBJECT) \ + (((((unsigned long) proc_tag) & HALF_OBJECT_LOW_MASK) \ + << HALF_OBJECT_LENGTH) \ + | (((unsigned long) dispatch) & HALF_OBJECT_LOW_MASK))) + +#define LABEL_PROCEDURE(pc) \ +(((* ((unsigned long *) (pc))) >> HALF_OBJECT_LENGTH) \ + & HALF_OBJECT_LOW_MASK) + +#define LABEL_TAG(pc) \ +((* ((unsigned long *) (pc))) & HALF_OBJECT_LOW_MASK) + +#define WRITE_LABEL_DESCRIPTOR(entry,kind,offset) do \ +{ \ + SCHEME_OBJECT * ent = ((SCHEME_OBJECT *) (entry)); \ + \ + COMPILED_ENTRY_FORMAT_WORD (entry) = (kind); \ + COMPILED_ENTRY_OFFSET_WORD (entry) = \ + (WORD_OFFSET_TO_OFFSET_WORD (offset)); \ +} while (0) + +#define CC_BLOCK_DISTANCE(block,entry) \ + (((SCHEME_OBJECT *) (entry)) - ((SCHEME_OBJECT *) (block))) + +typedef unsigned short format_word; + +extern int pc_zero_bits; + +#define PC_ZERO_BITS pc_zero_bits + +/* arbitrary */ +#define ENTRY_PREFIX_LENGTH 2 + +#define ADJUST_CLOSURE_AT_CALL(entry_point, location) do { } while (0) + +#define COMPILED_CLOSURE_ENTRY_SIZE ((sizeof (SCHEME_OBJECT)) * 3) + +#define EXTRACT_CLOSURE_ENTRY_ADDRESS(output,location) do \ +{ \ + (output) = (((SCHEME_OBJECT *) (location))[1]); \ +} while (0) + +#define STORE_CLOSURE_ENTRY_ADDRESS(input,location) do \ +{ \ + ((SCHEME_OBJECT *) (location))[1] = ((SCHEME_OBJECT) (input)); \ +} while (0) + +/* Trampolines are implemented as tiny compiled code blocks that + invoke the constant C procedure indexed by the number 0. + */ + +#define TRAMPOLINE_ENTRY_SIZE 2 /* Words */ + +#define TRAMPOLINE_BLOCK_TO_ENTRY 3 + +#define TRAMPOLINE_ENTRY_POINT(tramp_block) \ + (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY) + +#define TRAMPOLINE_STORAGE(tramp_entry) \ + ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ + (2 + TRAMPOLINE_ENTRY_SIZE)) + +#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \ +{ \ + ((SCHEME_OBJECT *) (entry_address))[0] \ + = (MAKE_LABEL_WORD (0, (index))); \ +} while (0) + +/* An execute cache contains a compiled entry for the callee, + and a number of arguments (+ 1). + */ + +#define EXECUTE_CACHE_ENTRY_SIZE 2 + +#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) do \ +{ \ + (target) = ((long) (((SCHEME_OBJECT *) (address))[1])); \ +} while (0) + +#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) do \ +{ \ + (target) = (((SCHEME_OBJECT *) (address))[0]); \ +} while (0) + +#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) do \ +{ \ + (target) = (((SCHEME_OBJECT *) (address)) [0]); \ +} while (0) + +#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) do \ +{ \ + ((SCHEME_OBJECT *) (address))[0] = ((SCHEME_OBJECT) (entry)); \ +} while (0) + +#define STORE_EXECUTE_CACHE_CODE(address) do { } while (0) + +extern void EXFUN (interface_initialize, (void)); + +#define ASM_RESET_HOOK() interface_initialize () + +/* Derived parameters and macros. + + These macros expect the above definitions to be meaningful. + If they are not, the macros below may have to be changed as well. + */ + +#define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1]) +#define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2]) + +/* The next one assumes 2's complement integers....*/ +#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) +#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) + +#define WORD_OFFSET_TO_OFFSET_WORD(words) ((words) << 1) + +#define BYTE_OFFSET_TO_OFFSET_WORD(bytes) \ + WORD_OFFSET_TO_OFFSET_WORD ((bytes) / (sizeof (SCHEME_OBJECT))) + +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + ((sizeof (SCHEME_OBJECT)) * ((CLEAR_LOW_BIT (offset_word)) >> 1)) + +#define MAKE_OFFSET_WORD(entry, block, continue) \ + ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ + ((char *) (block)))) | \ + ((continue) ? 1 : 0)) + +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) >> 1) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) << 1) + +/* The first entry in a cc block is preceeded by 2 headers (block and nmv), + a format word and a gc offset word. See the early part of the + TRAMPOLINE picture, above. + */ + +#define CC_BLOCK_FIRST_ENTRY_OFFSET \ + (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word)))) + +/* Format words */ + +#define FORMAT_BYTE_EXPR 0xFF +#define FORMAT_BYTE_COMPLR 0xFE +#define FORMAT_BYTE_CMPINT 0xFD +#define FORMAT_BYTE_DLINK 0xFC +#define FORMAT_BYTE_RETURN 0xFB + +#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR)) +#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT)) +#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN)) + +/* This assumes that a format word is at least 16 bits, + and the low order field is always 8 bits. + */ + +#define MAKE_FORMAT_WORD(field1, field2) \ + (((field1) << 8) | ((field2) & 0xff)) + +#define SIGN_EXTEND_FIELD(field, size) \ + (((field) & ((1 << (size)) - 1)) | \ + ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \ + ((-1) << (size)))) + +#define FORMAT_WORD_LOW_BYTE(word) \ + (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8)) + +#define FORMAT_WORD_HIGH_BYTE(word) \ + (SIGN_EXTEND_FIELD \ + ((((unsigned long) (word)) >> 8), \ + (((sizeof (format_word)) * CHAR_BIT) - 8))) + +#define COMPILED_ENTRY_FORMAT_HIGH(addr) \ + (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr))) + +#define COMPILED_ENTRY_FORMAT_LOW(addr) \ + (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr))) + +#define FORMAT_BYTE_FRAMEMAX 0x7f + +#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW +#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH + +#endif /* CMPINT2_H_INCLUDED */ diff --git a/v7/src/microcode/compinit.c b/v7/src/microcode/compinit.c new file mode 100644 index 000000000..b1935a5c3 --- /dev/null +++ b/v7/src/microcode/compinit.c @@ -0,0 +1,22 @@ +/* -*- C -*- */ + +#include "liarc.h" + +#undef DECLARE_COMPILED_CODE + +#define DECLARE_COMPILED_CODE(name, decl, code) do \ +{ \ + extern void EXFUN (decl, (void)); \ + extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *)); \ + if ((declare_compiled_code (name, decl, code)) == 0) \ + lose_big_1 ("DECLARE_COMPILED_CODE: duplicate tag", name); \ +} while (0) + +extern void EXFUN (lose_big_1, (char *, char *)); + +void +DEFUN_VOID (initialize_compiled_code_blocks) +{ +#include "compinit.h" + return; +} diff --git a/v7/src/microcode/liarc.h b/v7/src/microcode/liarc.h new file mode 100644 index 000000000..f60e54061 --- /dev/null +++ b/v7/src/microcode/liarc.h @@ -0,0 +1,476 @@ +/* -*-C-*- + +$Id: liarc.h,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +#ifndef LIARC_INCLUDED +#define LIARC_INCLUDED + +#include +#include "ansidecl.h" +#include "config.h" +#include "default.h" +#include "object.h" +#include "sdata.h" +#include "types.h" +#include "errors.h" +#include "const.h" +#include "interp.h" +#include "prim.h" +#include "cmpgc.h" +#include "cmpint2.h" + +#ifdef __STDC__ +# define USE_STDARG +# include +#else +# include +#endif /* __STDC__ */ + +/* #define USE_GLOBAL_VARIABLES */ +#define USE_SHORTCKT_JUMP + +typedef unsigned long ulong; + +extern PTR dstack_position; +extern SCHEME_OBJECT * Free; +extern SCHEME_OBJECT * Ext_Stack_Pointer; +extern SCHEME_OBJECT Registers[]; + +extern void EXFUN (lose_big, (char *)); +extern int EXFUN (multiply_with_overflow, (long, long, long *)); +extern SCHEME_OBJECT * EXFUN (invoke_utility, (int, long, long, long, long)); +extern void EXFUN (error_band_already_built, (void)); + +#define ERROR_UNKNOWN_DISPATCH( pc ) lose_big ("Unknown tag.") + +#define ADDRESS_UNITS_PER_OBJECT (sizeof (SCHEME_OBJECT)) + +#undef FIXNUM_TO_LONG +#define FIXNUM_TO_LONG(source) \ + ((((long) (source)) << TYPE_CODE_LENGTH) >> TYPE_CODE_LENGTH) + +#define ADDRESS_TO_LONG(source) ((long) (source)) + +#define LONG_TO_ADDRESS(source) (DATUM_TO_ADDRESS (source)) + +#define C_STRING_TO_SCHEME_STRING(len,str) \ + (MEMORY_TO_STRING ((len), (unsigned char *) str)) + +#define C_SYM_INTERN(len,str) \ + (MEMORY_TO_SYMBOL ((len), ((unsigned char *) str))) + +#define MAKE_PRIMITIVE_PROCEDURE(name,arity) \ + (SEARCH_FOR_PRIMITIVE (SHARP_F, name, true, true, arity)) + +#define MAKE_LINKER_HEADER(kind,count) \ + (OBJECT_NEW_TYPE (TC_FIXNUM, \ + (MAKE_LINKAGE_SECTION_HEADER ((kind), (count))))) + +#define ALLOCATE_VECTOR(len) (MAKE_VECTOR ((len), SHARP_F, true)) + +#define ALLOCATE_RECORD(len) \ + (OBJECT_NEW_TYPE (TC_RECORD, (ALLOCATE_VECTOR (len)))) + +#define RECORD_SET(rec,off,val) VECTOR_SET(rec,off,val) + +#define INLINE_DOUBLE_TO_FLONUM(src,tgt) do \ +{ \ + double num = (src); \ + SCHEME_OBJECT * val; \ + \ + ALIGN_FLOAT (free_pointer); \ + val = free_pointer; \ + free_pointer += (1 + (BYTES_TO_WORDS (sizeof (double)))); \ + * val = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \ + (BYTES_TO_WORDS (sizeof (double))))); \ + (* ((double *) (val + 1))) = num; \ + (tgt) = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (val))); \ +} while (0) + +#define MAKE_RATIO(num,den) \ + (OBJECT_NEW_TYPE (TC_RATNUM, (CONS (num, den)))) + +#define MAKE_COMPLEX(real,imag) \ + (OBJECT_NEW_TYPE (TC_COMPLEX, (CONS (real, imag)))) + +#define CC_BLOCK_TO_ENTRY(block,offset) \ + (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, \ + ((OBJECT_ADDRESS (block)) + (offset)))) + +#ifdef USE_GLOBAL_VARIABLES + +#define value_reg Val +#define free_pointer Free +#define register_block Regs +#define stack_pointer Stack_Pointer + +#define DECLARE_VARIABLES() int unsed_variable_to_keep_C_happy +#define UNCACHE_VARIABLES() do {} while (0) +#define CACHE_VARIABLES() do {} while (0) + +#else /* not USE_GLOBAL_VARIABLES */ + +#define REGISTER register + +#define register_block Regs + +#define DECLARE_VARIABLES() \ +REGISTER SCHEME_OBJECT value_reg = Val; \ +REGISTER SCHEME_OBJECT * free_pointer = Free; \ +REGISTER SCHEME_OBJECT * stack_pointer = Stack_Pointer + +#define UNCACHE_VARIABLES() do \ +{ \ + Stack_Pointer = stack_pointer; \ + Free = free_pointer; \ + Val = value_reg; \ +} while (0) + +#define CACHE_VARIABLES() do \ +{ \ + value_reg = Val; \ + free_pointer = Free; \ + stack_pointer = Stack_Pointer; \ +} while (0) + +#endif /* USE_GLOBAL_VARIABLES */ + +#define REPEAT_DISPATCH() do \ +{ \ + if ((LABEL_PROCEDURE (my_pc)) != current_C_proc) \ + { \ + UNCACHE_VARIABLES (); \ + return (my_pc); \ + } \ + /* fall through. */ \ +} while (0) + +#ifdef USE_SHORTCKT_JUMP + +#define JUMP(destination) do \ +{ \ + my_pc = (destination); \ + goto repeat_dispatch; \ +} while(0) + +#define JUMP_EXTERNAL(destination) do \ +{ \ + my_pc = (destination); \ + if ((LABEL_PROCEDURE (my_pc)) == current_C_proc) \ + { \ + CACHE_VARIABLES (); \ + goto perform_dispatch; \ + } \ + return (my_pc); \ +} while (0) + +#define JUMP_EXECUTE_CHACHE(entry) do \ +{ \ + my_pc = ((SCHEME_OBJECT *) current_block[entry]); \ + goto repeat_dispatch; \ +} while (0) + +#define POP_RETURN() goto pop_return_repeat_dispatch + +#define POP_RETURN_REPEAT_DISPATCH() do \ +{ \ + my_pc = (OBJECT_ADDRESS (*stack_pointer++)); \ + /* fall through to repeat_dispatch */ \ +} while (0) + +#else /* not USE_SHORTCKT_JUMP */ + +#define JUMP(destination) do \ +{ \ + UNCACHE_VARIABLES (); \ + return (destination); \ +} while (0) + +#define JUMP_EXTERNAL(destination) return (destination) + +#define JUMP_EXECUTE_CHACHE(entry) do \ +{ \ + SCHEME_OBJECT* destination \ + = ((SCHEME_OBJECT *) current_block[entry]); \ + \ + JUMP (destination); \ +} while (0) + +#define POP_RETURN() do \ +{ \ + SCHEME_OBJECT target = *stack_pointer++; \ + SCHEME_OBJECT destination = (OBJECT_ADDRESS (target)); \ + JUMP (destination); \ +} while (0) + +#define POP_RETURN_REPEAT_DISPATCH() do \ +{ \ +} while (0) + +#endif /* USE_SHORTCKT_JUMP */ + +#define INVOKE_PRIMITIVE(prim, nargs) do \ +{ \ + primitive = (prim); \ + primitive_nargs = (nargs); \ + goto invoke_primitive; \ +} while (0) + +#define INVOKE_PRIMITIVE_CODE() do \ +{ \ + SCHEME_OBJECT * destination; \ + \ + UNCACHE_VARIABLES (); \ + PRIMITIVE_APPLY (Val, primitive); \ + POP_PRIMITIVE_FRAME (primitive_nargs); \ + destination = (OBJECT_ADDRESS (STACK_POP ())); \ + JUMP_EXTERNAL (destination); \ +} while(0) + +#define INVOKE_INTERFACE_CODE() do \ +{ \ + SCHEME_OBJECT * destination; \ + \ + UNCACHE_VARIABLES (); \ + destination = (invoke_utility (subtmp_code, subtmp_1, subtmp_2, \ + subtmp_3, subtmp_4)); \ + JUMP_EXTERNAL (destination); \ +} while (0) + +#define INVOKE_INTERFACE_4(code, one, two, three, four) do \ +{ \ + subtmp_4 = ((long) (four)); \ + subtmp_3 = ((long) (three)); \ + subtmp_2 = ((long) (two)); \ + subtmp_1 = ((long) (one)); \ + subtmp_code = (code); \ + goto invoke_interface_4; \ +} while (0) + +#define INVOKE_INTERFACE_3(code, one, two, three) do \ +{ \ + subtmp_3 = ((long) (three)); \ + subtmp_2 = ((long) (two)); \ + subtmp_1 = ((long) (one)); \ + subtmp_code = (code); \ + goto invoke_interface_3; \ +} while (0) + +#define INVOKE_INTERFACE_2(code, one, two) do \ +{ \ + subtmp_2 = ((long) (two)); \ + subtmp_1 = ((long) (one)); \ + subtmp_code = (code); \ + goto invoke_interface_2; \ +} while (0) + +#define INVOKE_INTERFACE_1(code, one) do \ +{ \ + subtmp_1 = ((long) (one)); \ + subtmp_code = (code); \ + goto invoke_interface_1; \ +} while (0) + +#define INVOKE_INTERFACE_0(code) do \ +{ \ + subtmp_code = (code); \ + goto invoke_interface_0; \ +} while (0) + +#define MAX_BIT_SHIFT DATUM_LENGTH + +#define RIGHT_SHIFT_UNSIGNED(source, number) \ +(((number) > MAX_BIT_SHIFT) \ + ? 0 \ + : ((((unsigned long) (source)) & DATUM_MASK) \ + >> (number))) + +#define RIGHT_SHIFT(source, number) \ +(((number) > MAX_BIT_SHIFT) \ + ? 0 \ + : ((source) >> (number))) + +#define LEFT_SHIFT(source, number) \ +(((number) > MAX_BIT_SHIFT) \ + ? 0 \ + : ((source) << (number))) + +#define FIXNUM_LSH(source, number) \ +(((number) >= 0) \ + ? (LEFT_SHIFT (source, number)) \ + : (RIGHT_SHIFT_UNSIGNED (source, (- (number))))) + +#define FIXNUM_REMAINDER(source1, source2) \ +(((source2) > 0) \ + ? (((source1) >= 0) \ + ? ((source1) % (source2)) \ + : (- ((- (source1)) % (source2)))) \ + : (((source1) >= 0) \ + ? ((source1) % (- (source2))) \ + : (- ((- (source1)) % (- (source2)))))) + +#define FIXNUM_QUOTIENT(source1, source2) \ +(((source2) > 0) \ + ? (((source1) >= 0) \ + ? ((source1) / (source2)) \ + : (- ((- (source1)) / (source2)))) \ + : (((source1) >= 0) \ + ? (- ((source1) / (- (source2)))) \ + : ((- (source1)) / (- (source2))))) + +#define CLOSURE_HEADER(offset) do \ +{ \ + SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) my_pc[1]); \ + current_block = (entry - offset); \ + *--stack_pointer = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, my_pc)); \ +} while (0) + +#define CLOSURE_INTERRUPT_CHECK(code) do \ +{ \ + if (((long) free_pointer) \ + >= ((long) (register_block[REGBLOCK_MEMTOP]))) \ + INVOKE_INTERFACE_0 (code); \ +} while (0) + +#define INTERRUPT_CHECK(code, entry_point) do \ +{ \ + if (((long) free_pointer) \ + >= ((long) (register_block[REGBLOCK_MEMTOP]))) \ + INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]); \ +} while (0) + +#define DLINK_INTERRUPT_CHECK(code, entry_point) do \ +{ \ + if (((long) free_pointer) \ + >= ((long) (register_block[REGBLOCK_MEMTOP]))) \ + INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], \ + dynamic_link); \ +} while (0) + +/* This does nothing in the sources. */ + +#define DECLARE_COMPILED_CODE(string, decl, code) \ +extern void EXFUN (decl, (void)); \ +extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *)); + +#ifdef USE_STDARG +# define RCONSM_TYPE(frob) SCHEME_OBJECT EXFUN (frob, (int, SCHEME_OBJECT DOTS)) +#else /* not USE_STDARG */ +# define RCONSM_TYPE(frob) SCHEME_OBJECT frob () +#endif /* USE_STDARG */ + +extern RCONSM_TYPE(rconsm); + +struct compiled_file +{ + int number_of_procedures; + char ** names; + void * EXFUN ((**procs), (void)); +}; + +extern int EXFUN (declare_compiled_code, + (char *, + void EXFUN ((*), (void)), + SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *)))); +extern SCHEME_OBJECT EXFUN (initialize_subblock, (char *)); +extern void EXFUN (NO_SUBBLOCKS, (void)); + +#ifdef __GNUC__ +# ifdef hp9000s800 +# define BUG_GCC_LONG_CALLS +# endif +#endif + +#ifndef BUG_GCC_LONG_CALLS + +extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *)); +extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *)); +extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean)); +extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT)); +extern SCHEME_OBJECT EXFUN (double_to_flonum, (double)); +extern SCHEME_OBJECT EXFUN (long_to_integer, (long)); +extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *)); +extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *)); +extern SCHEME_OBJECT EXFUN (search_for_primitive, + (SCHEME_OBJECT, char *, Boolean, Boolean, int)); + +#define MEMORY_TO_STRING memory_to_string +#define MEMORY_TO_SYMBOL memory_to_symbol +#define MAKE_VECTOR make_vector +#define CONS cons +#define RCONSM rconsm +#define DOUBLE_TO_FLONUM double_to_flonum +#define LONG_TO_INTEGER long_to_integer +#define DIGIT_STRING_TO_INTEGER digit_string_to_integer +#define DIGIT_STRING_TO_BIT_STRING digit_string_to_bit_string +#define SEARCH_FOR_PRIMITIVE search_for_primitive + +#else /* GCC on Specturm has a strange bug so do thing differently .... */ + +extern SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ()); + +#define MEMORY_TO_STRING \ + ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) (constructor_kludge[0])) + +#define MEMORY_TO_SYMBOL \ + ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) (constructor_kludge[1])) + +#define MAKE_VECTOR \ + ((SCHEME_OBJECT EXFUN ((*), (long, SCHEME_OBJECT, Boolean))) (constructor_kludge[2])) + +#define CONS \ + ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, SCHEME_OBJECT))) (constructor_kludge[3])) + +#define RCONSM \ + ((RCONSM_TYPE ((*))) (constructor_kludge[4])) + +#define DOUBLE_TO_FLONUM \ + ((SCHEME_OBJECT EXFUN ((*), (double))) (constructor_kludge[5])) + +#define LONG_TO_INTEGER \ + ((SCHEME_OBJECT EXFUN ((*), (long))) (constructor_kludge[6])) + +#define DIGIT_STRING_TO_INTEGER \ + ((SCHEME_OBJECT EXFUN ((*), (Boolean, long, char *))) (constructor_kludge[7])) + +#define DIGIT_STRING_TO_BIT_STRING \ + ((SCHEME_OBJECT EXFUN ((*), (long, long, char *))) (constructor_kludge[8])) + +#define SEARCH_FOR_PRIMITIVE \ + ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, char *, \ + Boolean, Boolean, int))) \ + (constructor_kludge[9])) + +#endif /* BUG_GCC_LONG_CALLS */ + +#endif /* LIARC_INCLUDED */ diff --git a/v8/src/microcode/liarc.h b/v8/src/microcode/liarc.h new file mode 100644 index 000000000..f60e54061 --- /dev/null +++ b/v8/src/microcode/liarc.h @@ -0,0 +1,476 @@ +/* -*-C-*- + +$Id: liarc.h,v 1.1 1993/06/08 06:13:32 gjr Exp $ + +Copyright (c) 1992-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +#ifndef LIARC_INCLUDED +#define LIARC_INCLUDED + +#include +#include "ansidecl.h" +#include "config.h" +#include "default.h" +#include "object.h" +#include "sdata.h" +#include "types.h" +#include "errors.h" +#include "const.h" +#include "interp.h" +#include "prim.h" +#include "cmpgc.h" +#include "cmpint2.h" + +#ifdef __STDC__ +# define USE_STDARG +# include +#else +# include +#endif /* __STDC__ */ + +/* #define USE_GLOBAL_VARIABLES */ +#define USE_SHORTCKT_JUMP + +typedef unsigned long ulong; + +extern PTR dstack_position; +extern SCHEME_OBJECT * Free; +extern SCHEME_OBJECT * Ext_Stack_Pointer; +extern SCHEME_OBJECT Registers[]; + +extern void EXFUN (lose_big, (char *)); +extern int EXFUN (multiply_with_overflow, (long, long, long *)); +extern SCHEME_OBJECT * EXFUN (invoke_utility, (int, long, long, long, long)); +extern void EXFUN (error_band_already_built, (void)); + +#define ERROR_UNKNOWN_DISPATCH( pc ) lose_big ("Unknown tag.") + +#define ADDRESS_UNITS_PER_OBJECT (sizeof (SCHEME_OBJECT)) + +#undef FIXNUM_TO_LONG +#define FIXNUM_TO_LONG(source) \ + ((((long) (source)) << TYPE_CODE_LENGTH) >> TYPE_CODE_LENGTH) + +#define ADDRESS_TO_LONG(source) ((long) (source)) + +#define LONG_TO_ADDRESS(source) (DATUM_TO_ADDRESS (source)) + +#define C_STRING_TO_SCHEME_STRING(len,str) \ + (MEMORY_TO_STRING ((len), (unsigned char *) str)) + +#define C_SYM_INTERN(len,str) \ + (MEMORY_TO_SYMBOL ((len), ((unsigned char *) str))) + +#define MAKE_PRIMITIVE_PROCEDURE(name,arity) \ + (SEARCH_FOR_PRIMITIVE (SHARP_F, name, true, true, arity)) + +#define MAKE_LINKER_HEADER(kind,count) \ + (OBJECT_NEW_TYPE (TC_FIXNUM, \ + (MAKE_LINKAGE_SECTION_HEADER ((kind), (count))))) + +#define ALLOCATE_VECTOR(len) (MAKE_VECTOR ((len), SHARP_F, true)) + +#define ALLOCATE_RECORD(len) \ + (OBJECT_NEW_TYPE (TC_RECORD, (ALLOCATE_VECTOR (len)))) + +#define RECORD_SET(rec,off,val) VECTOR_SET(rec,off,val) + +#define INLINE_DOUBLE_TO_FLONUM(src,tgt) do \ +{ \ + double num = (src); \ + SCHEME_OBJECT * val; \ + \ + ALIGN_FLOAT (free_pointer); \ + val = free_pointer; \ + free_pointer += (1 + (BYTES_TO_WORDS (sizeof (double)))); \ + * val = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \ + (BYTES_TO_WORDS (sizeof (double))))); \ + (* ((double *) (val + 1))) = num; \ + (tgt) = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (val))); \ +} while (0) + +#define MAKE_RATIO(num,den) \ + (OBJECT_NEW_TYPE (TC_RATNUM, (CONS (num, den)))) + +#define MAKE_COMPLEX(real,imag) \ + (OBJECT_NEW_TYPE (TC_COMPLEX, (CONS (real, imag)))) + +#define CC_BLOCK_TO_ENTRY(block,offset) \ + (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, \ + ((OBJECT_ADDRESS (block)) + (offset)))) + +#ifdef USE_GLOBAL_VARIABLES + +#define value_reg Val +#define free_pointer Free +#define register_block Regs +#define stack_pointer Stack_Pointer + +#define DECLARE_VARIABLES() int unsed_variable_to_keep_C_happy +#define UNCACHE_VARIABLES() do {} while (0) +#define CACHE_VARIABLES() do {} while (0) + +#else /* not USE_GLOBAL_VARIABLES */ + +#define REGISTER register + +#define register_block Regs + +#define DECLARE_VARIABLES() \ +REGISTER SCHEME_OBJECT value_reg = Val; \ +REGISTER SCHEME_OBJECT * free_pointer = Free; \ +REGISTER SCHEME_OBJECT * stack_pointer = Stack_Pointer + +#define UNCACHE_VARIABLES() do \ +{ \ + Stack_Pointer = stack_pointer; \ + Free = free_pointer; \ + Val = value_reg; \ +} while (0) + +#define CACHE_VARIABLES() do \ +{ \ + value_reg = Val; \ + free_pointer = Free; \ + stack_pointer = Stack_Pointer; \ +} while (0) + +#endif /* USE_GLOBAL_VARIABLES */ + +#define REPEAT_DISPATCH() do \ +{ \ + if ((LABEL_PROCEDURE (my_pc)) != current_C_proc) \ + { \ + UNCACHE_VARIABLES (); \ + return (my_pc); \ + } \ + /* fall through. */ \ +} while (0) + +#ifdef USE_SHORTCKT_JUMP + +#define JUMP(destination) do \ +{ \ + my_pc = (destination); \ + goto repeat_dispatch; \ +} while(0) + +#define JUMP_EXTERNAL(destination) do \ +{ \ + my_pc = (destination); \ + if ((LABEL_PROCEDURE (my_pc)) == current_C_proc) \ + { \ + CACHE_VARIABLES (); \ + goto perform_dispatch; \ + } \ + return (my_pc); \ +} while (0) + +#define JUMP_EXECUTE_CHACHE(entry) do \ +{ \ + my_pc = ((SCHEME_OBJECT *) current_block[entry]); \ + goto repeat_dispatch; \ +} while (0) + +#define POP_RETURN() goto pop_return_repeat_dispatch + +#define POP_RETURN_REPEAT_DISPATCH() do \ +{ \ + my_pc = (OBJECT_ADDRESS (*stack_pointer++)); \ + /* fall through to repeat_dispatch */ \ +} while (0) + +#else /* not USE_SHORTCKT_JUMP */ + +#define JUMP(destination) do \ +{ \ + UNCACHE_VARIABLES (); \ + return (destination); \ +} while (0) + +#define JUMP_EXTERNAL(destination) return (destination) + +#define JUMP_EXECUTE_CHACHE(entry) do \ +{ \ + SCHEME_OBJECT* destination \ + = ((SCHEME_OBJECT *) current_block[entry]); \ + \ + JUMP (destination); \ +} while (0) + +#define POP_RETURN() do \ +{ \ + SCHEME_OBJECT target = *stack_pointer++; \ + SCHEME_OBJECT destination = (OBJECT_ADDRESS (target)); \ + JUMP (destination); \ +} while (0) + +#define POP_RETURN_REPEAT_DISPATCH() do \ +{ \ +} while (0) + +#endif /* USE_SHORTCKT_JUMP */ + +#define INVOKE_PRIMITIVE(prim, nargs) do \ +{ \ + primitive = (prim); \ + primitive_nargs = (nargs); \ + goto invoke_primitive; \ +} while (0) + +#define INVOKE_PRIMITIVE_CODE() do \ +{ \ + SCHEME_OBJECT * destination; \ + \ + UNCACHE_VARIABLES (); \ + PRIMITIVE_APPLY (Val, primitive); \ + POP_PRIMITIVE_FRAME (primitive_nargs); \ + destination = (OBJECT_ADDRESS (STACK_POP ())); \ + JUMP_EXTERNAL (destination); \ +} while(0) + +#define INVOKE_INTERFACE_CODE() do \ +{ \ + SCHEME_OBJECT * destination; \ + \ + UNCACHE_VARIABLES (); \ + destination = (invoke_utility (subtmp_code, subtmp_1, subtmp_2, \ + subtmp_3, subtmp_4)); \ + JUMP_EXTERNAL (destination); \ +} while (0) + +#define INVOKE_INTERFACE_4(code, one, two, three, four) do \ +{ \ + subtmp_4 = ((long) (four)); \ + subtmp_3 = ((long) (three)); \ + subtmp_2 = ((long) (two)); \ + subtmp_1 = ((long) (one)); \ + subtmp_code = (code); \ + goto invoke_interface_4; \ +} while (0) + +#define INVOKE_INTERFACE_3(code, one, two, three) do \ +{ \ + subtmp_3 = ((long) (three)); \ + subtmp_2 = ((long) (two)); \ + subtmp_1 = ((long) (one)); \ + subtmp_code = (code); \ + goto invoke_interface_3; \ +} while (0) + +#define INVOKE_INTERFACE_2(code, one, two) do \ +{ \ + subtmp_2 = ((long) (two)); \ + subtmp_1 = ((long) (one)); \ + subtmp_code = (code); \ + goto invoke_interface_2; \ +} while (0) + +#define INVOKE_INTERFACE_1(code, one) do \ +{ \ + subtmp_1 = ((long) (one)); \ + subtmp_code = (code); \ + goto invoke_interface_1; \ +} while (0) + +#define INVOKE_INTERFACE_0(code) do \ +{ \ + subtmp_code = (code); \ + goto invoke_interface_0; \ +} while (0) + +#define MAX_BIT_SHIFT DATUM_LENGTH + +#define RIGHT_SHIFT_UNSIGNED(source, number) \ +(((number) > MAX_BIT_SHIFT) \ + ? 0 \ + : ((((unsigned long) (source)) & DATUM_MASK) \ + >> (number))) + +#define RIGHT_SHIFT(source, number) \ +(((number) > MAX_BIT_SHIFT) \ + ? 0 \ + : ((source) >> (number))) + +#define LEFT_SHIFT(source, number) \ +(((number) > MAX_BIT_SHIFT) \ + ? 0 \ + : ((source) << (number))) + +#define FIXNUM_LSH(source, number) \ +(((number) >= 0) \ + ? (LEFT_SHIFT (source, number)) \ + : (RIGHT_SHIFT_UNSIGNED (source, (- (number))))) + +#define FIXNUM_REMAINDER(source1, source2) \ +(((source2) > 0) \ + ? (((source1) >= 0) \ + ? ((source1) % (source2)) \ + : (- ((- (source1)) % (source2)))) \ + : (((source1) >= 0) \ + ? ((source1) % (- (source2))) \ + : (- ((- (source1)) % (- (source2)))))) + +#define FIXNUM_QUOTIENT(source1, source2) \ +(((source2) > 0) \ + ? (((source1) >= 0) \ + ? ((source1) / (source2)) \ + : (- ((- (source1)) / (source2)))) \ + : (((source1) >= 0) \ + ? (- ((source1) / (- (source2)))) \ + : ((- (source1)) / (- (source2))))) + +#define CLOSURE_HEADER(offset) do \ +{ \ + SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) my_pc[1]); \ + current_block = (entry - offset); \ + *--stack_pointer = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, my_pc)); \ +} while (0) + +#define CLOSURE_INTERRUPT_CHECK(code) do \ +{ \ + if (((long) free_pointer) \ + >= ((long) (register_block[REGBLOCK_MEMTOP]))) \ + INVOKE_INTERFACE_0 (code); \ +} while (0) + +#define INTERRUPT_CHECK(code, entry_point) do \ +{ \ + if (((long) free_pointer) \ + >= ((long) (register_block[REGBLOCK_MEMTOP]))) \ + INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]); \ +} while (0) + +#define DLINK_INTERRUPT_CHECK(code, entry_point) do \ +{ \ + if (((long) free_pointer) \ + >= ((long) (register_block[REGBLOCK_MEMTOP]))) \ + INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], \ + dynamic_link); \ +} while (0) + +/* This does nothing in the sources. */ + +#define DECLARE_COMPILED_CODE(string, decl, code) \ +extern void EXFUN (decl, (void)); \ +extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *)); + +#ifdef USE_STDARG +# define RCONSM_TYPE(frob) SCHEME_OBJECT EXFUN (frob, (int, SCHEME_OBJECT DOTS)) +#else /* not USE_STDARG */ +# define RCONSM_TYPE(frob) SCHEME_OBJECT frob () +#endif /* USE_STDARG */ + +extern RCONSM_TYPE(rconsm); + +struct compiled_file +{ + int number_of_procedures; + char ** names; + void * EXFUN ((**procs), (void)); +}; + +extern int EXFUN (declare_compiled_code, + (char *, + void EXFUN ((*), (void)), + SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *)))); +extern SCHEME_OBJECT EXFUN (initialize_subblock, (char *)); +extern void EXFUN (NO_SUBBLOCKS, (void)); + +#ifdef __GNUC__ +# ifdef hp9000s800 +# define BUG_GCC_LONG_CALLS +# endif +#endif + +#ifndef BUG_GCC_LONG_CALLS + +extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *)); +extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *)); +extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean)); +extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT)); +extern SCHEME_OBJECT EXFUN (double_to_flonum, (double)); +extern SCHEME_OBJECT EXFUN (long_to_integer, (long)); +extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *)); +extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *)); +extern SCHEME_OBJECT EXFUN (search_for_primitive, + (SCHEME_OBJECT, char *, Boolean, Boolean, int)); + +#define MEMORY_TO_STRING memory_to_string +#define MEMORY_TO_SYMBOL memory_to_symbol +#define MAKE_VECTOR make_vector +#define CONS cons +#define RCONSM rconsm +#define DOUBLE_TO_FLONUM double_to_flonum +#define LONG_TO_INTEGER long_to_integer +#define DIGIT_STRING_TO_INTEGER digit_string_to_integer +#define DIGIT_STRING_TO_BIT_STRING digit_string_to_bit_string +#define SEARCH_FOR_PRIMITIVE search_for_primitive + +#else /* GCC on Specturm has a strange bug so do thing differently .... */ + +extern SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ()); + +#define MEMORY_TO_STRING \ + ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) (constructor_kludge[0])) + +#define MEMORY_TO_SYMBOL \ + ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) (constructor_kludge[1])) + +#define MAKE_VECTOR \ + ((SCHEME_OBJECT EXFUN ((*), (long, SCHEME_OBJECT, Boolean))) (constructor_kludge[2])) + +#define CONS \ + ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, SCHEME_OBJECT))) (constructor_kludge[3])) + +#define RCONSM \ + ((RCONSM_TYPE ((*))) (constructor_kludge[4])) + +#define DOUBLE_TO_FLONUM \ + ((SCHEME_OBJECT EXFUN ((*), (double))) (constructor_kludge[5])) + +#define LONG_TO_INTEGER \ + ((SCHEME_OBJECT EXFUN ((*), (long))) (constructor_kludge[6])) + +#define DIGIT_STRING_TO_INTEGER \ + ((SCHEME_OBJECT EXFUN ((*), (Boolean, long, char *))) (constructor_kludge[7])) + +#define DIGIT_STRING_TO_BIT_STRING \ + ((SCHEME_OBJECT EXFUN ((*), (long, long, char *))) (constructor_kludge[8])) + +#define SEARCH_FOR_PRIMITIVE \ + ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, char *, \ + Boolean, Boolean, int))) \ + (constructor_kludge[9])) + +#endif /* BUG_GCC_LONG_CALLS */ + +#endif /* LIARC_INCLUDED */