From 8229c909ceb2dbb046fcdd80e0a769637f603b9a Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 2 Jan 2010 20:00:52 -0700 Subject: [PATCH] Got the (incomplete) svm1 back end to syntax. * src/compiler/choose-machine.sh: Added a test that produces the correct directory name (svm) for TARGET_ARCH svm1. * src/compiler/machines/svm/.gitignore (new): Ignore generated files. * src/compiler/machines/svm/assembler-compiler.scm: Fixed to produce non-empty let bodies in the codecs of instructions with zero arguments, and fewer unreferenced bindings. * src/compiler/machines/svm/assembler-runtime.scm: Introduced a module variable, coding-types, to hold the list of s created by make-rt-coding-type. The list is thus no longer required as an argument to many procedures. Fixed the trap:* procedures to accept trap arguments. Fixed the interface to the interrupt test instructions, which are not (no longer?) traps. * src/compiler/machines/svm/compile-assembler.scm: Added a temporary hack to define write-mit-scheme-copyright in January's snapshot. * src/compiler/machines/svm/compiler.cbf (new): Cribbed from i386. * src/compiler/machines/svm/compiler.pkg (new): Cribbed from i386. * src/compiler/machines/svm/compiler.sf (new): Cribbed from i386. Referring to compiler.pkg's declarations to get the syntax/load environments right. * src/compiler/machines/svm/decls.scm (new): Cribbed from i386. Collect the list of source files from compiler.pkg, not via *.scm globs. Punted initialize/syntax-dependencies!, getting the correct syntax/load environments from compiler.pkg. * src/compiler/machines/svm/lapgen.scm: Fixed some typos and unreferenced bindings. --- src/compiler/choose-machine.sh | 7 +- src/compiler/machines/svm/.gitignore | 4 + .../machines/svm/assembler-compiler.scm | 31 +- .../machines/svm/assembler-runtime.scm | 57 +- .../machines/svm/compile-assembler.scm | 12 +- src/compiler/machines/svm/compiler.cbf | 37 + src/compiler/machines/svm/compiler.pkg | 756 ++++++++++++++++++ src/compiler/machines/svm/compiler.sf | 90 +++ src/compiler/machines/svm/decls.scm | 529 ++++++++++++ src/compiler/machines/svm/lapgen.scm | 13 +- 10 files changed, 1495 insertions(+), 41 deletions(-) create mode 100644 src/compiler/machines/svm/.gitignore create mode 100644 src/compiler/machines/svm/compiler.cbf create mode 100644 src/compiler/machines/svm/compiler.pkg create mode 100644 src/compiler/machines/svm/compiler.sf create mode 100644 src/compiler/machines/svm/decls.scm diff --git a/src/compiler/choose-machine.sh b/src/compiler/choose-machine.sh index 7aca4966a..dc8f91dc0 100755 --- a/src/compiler/choose-machine.sh +++ b/src/compiler/choose-machine.sh @@ -2,7 +2,7 @@ # Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, # 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -# 2005, 2006, 2007, 2008, 2009 Massachusetts Institute of +# 2005, 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of # Technology # # This file is part of MIT/GNU Scheme. @@ -36,6 +36,11 @@ if test x"${TARGET_ARCH}" = xc; then exit 0 fi +if test x"${TARGET_ARCH}" = xsvm1; then + echo svm + exit 0 +fi + if test -d "${HERE}/machines/${TARGET_ARCH}"; then echo "${TARGET_ARCH}" exit 0 diff --git a/src/compiler/machines/svm/.gitignore b/src/compiler/machines/svm/.gitignore new file mode 100644 index 000000000..26b0acef8 --- /dev/null +++ b/src/compiler/machines/svm/.gitignore @@ -0,0 +1,4 @@ +assembler-db.scm +assembler-rules.exp +svm1-defns.h +svm1-opcodes.scm diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm index 769eed1d7..297c0beed 100644 --- a/src/compiler/machines/svm/assembler-compiler.scm +++ b/src/compiler/machines/svm/assembler-compiler.scm @@ -2,7 +2,7 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009 Massachusetts Institute of Technology + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -134,6 +134,7 @@ USA. (check-coding-type-graph coding-types)) (define (check-defn defn coding-types) + coding-types ;; Check for duplicate pattern variables. (do ((pvars (defn-pvars defn) (cdr pvars))) ((not (pair? pvars))) @@ -849,13 +850,10 @@ USA. (newline port)) (define (write-copyright+license pathname port) + pathname (write-string "DO NOT EDIT: this file was generated by a program." port) (newline port) (newline port) - ;; Don't use dollar-sign; could cause unwanted keyword expansion. - (write-string "\044Id\044" port) - (newline port) - (newline port) (write-mit-scheme-copyright port) (newline port) (newline port) @@ -1002,14 +1000,16 @@ USA. (define (rt-defn-encoder-constructor defn) `(LAMBDA (INSTANCE WRITE-BYTE) - ,@(map (lambda (item) + ,@(if (null? (defn-coding defn)) + '(INSTANCE WRITE-BYTE UNSPECIFIC) + (map (lambda (item) (let ((pval `(RT-INSTANCE-PVAL ',(pvar-name item) INSTANCE)) (pvt (lookup-pvar-type (pvar-type item)))) (if pvt `(,(pvt-encoder pvt) ,pval WRITE-BYTE) `(LET ((PVAL ,pval)) ((RT-INSTANCE-ENCODER PVAL) PVAL WRITE-BYTE))))) - (defn-coding defn)))) + (defn-coding defn))))) (define (rt-defn-decoder-constructor defn) (let ((pvars (defn-pvars defn))) @@ -1022,16 +1022,19 @@ USA. `(DECODE-RT-CODING-TYPE ',(pvar-type pv) READ-BYTE CODING-TYPES)))))) - `(LAMBDA (READ-BYTE CODING-TYPES) - ,(if (fix:= n-pvars 1) - `(LIST ,(body (car pvars))) - `(LET* ,(map (lambda (pv) - `(,(symbol 'V (pvar-index pv pvars)) ,(body pv))) - (defn-coding defn)) + `(LAMBDA (READ-BYTE) + ,@(cond((fix:= n-pvars 0) + `(READ-BYTE CODING-TYPES '())) + ((fix:= n-pvars 1) + `((LIST ,(body (car pvars))))) + (else + `((LET* ,(map (lambda (pv) + `(,(symbol 'V (pvar-index pv pvars)) ,(body pv))) + (defn-coding defn)) (LIST ,@(let loop ((i 0)) (if (fix:< i n-pvars) (cons (symbol 'V i) (loop (fix:+ i 1))) - '()))))))))) + '()))))))))))) (define (pvar-index pv pvars) (let loop ((pvars pvars) (index 0)) diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm index 282dcf962..530537cec 100644 --- a/src/compiler/machines/svm/assembler-runtime.scm +++ b/src/compiler/machines/svm/assembler-runtime.scm @@ -2,7 +2,7 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009 Massachusetts Institute of Technology + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -36,11 +36,21 @@ USA. ;;; machine instructions, which are distinguished by an opcode byte. (define-record-type - (make-rt-coding-type name defns) + (%make-rt-coding-type name defns) rt-coding-type? (name rt-coding-type-name) (defns rt-coding-type-defns)) +(define rt-coding-types '()) + +(define (make-rt-coding-type name defns) + (if (find-matching-item rt-coding-types + (lambda (rt-coding-type) + (eq? (rt-coding-type-name rt-coding-type) name))) + (error "Coding type already exists" name) + (set! rt-coding-types + (cons (%make-rt-coding-type name defns) rt-coding-types)))) + ;;; Each coding type has a number of definitions, each of which ;;; represents the code sequence associated with a particular value of ;;; the coding-type's code byte. Each definition has a pattern (or @@ -113,20 +123,19 @@ USA. ;;; **** where are real top-level entries? **** -(define (match-rt-coding-type name expression coding-types symbol-table) - (let loop ((defns (rt-coding-type-defns (rt-coding-type name coding-types)))) +(define (match-rt-coding-type name expression symbol-table) + (let loop ((defns (rt-coding-type-defns (rt-coding-type name)))) (and (pair? defns) (let ((pvals (match-pattern (rt-defn-pattern (car defns)) expression - coding-types symbol-table))) (if pvals (make-rt-instance (car defns) pvals) (loop (cdr defns))))))) -(define (decode-rt-coding-type name read-byte coding-types) - (let ((type (rt-coding-type name coding-types)) +(define (decode-rt-coding-type name read-byte) + (let ((type (rt-coding-type name)) (code (read-byte))) (let ((rcd (find-matching-item (rt-coding-type-defns type) @@ -134,10 +143,11 @@ USA. (eqv? (rt-defn-code rcd) code))))) (if (not rcd) (error "No matching code:" code type)) - (make-rt-instance rcd ((rt-defn-decoder rcd) read-byte coding-types))))) + (make-rt-instance rcd ((rt-defn-decoder rcd) + read-byte rt-coding-types))))) -(define (rt-coding-type name coding-types) - (or (find-matching-item coding-types +(define (rt-coding-type name) + (or (find-matching-item rt-coding-types (lambda (rt-coding-type) (eq? (rt-coding-type-name rt-coding-type) name))) (error:bad-range-argument name 'RT-CODING-TYPE))) @@ -186,7 +196,7 @@ USA. (define-integrable (pvar-name pv) (cadr pv)) (define-integrable (pvar-type pv) (caddr pv)) -(define (match-pattern pattern expression coding-types symbol-table) +(define (match-pattern pattern expression symbol-table) (let loop ((pattern pattern) (expression expression) (pvals '())) (if (pair? pattern) (if (eq? (car pattern) '_) @@ -200,7 +210,6 @@ USA. (let ((instance (match-rt-coding-type (pvar-type pattern) expression - coding-types symbol-table))) (and instance (cons instance pvals))))) @@ -388,7 +397,8 @@ USA. (let ((name (symbol-append 'EA: tag))) `(BEGIN (DEFINE-INTEGRABLE (,name ,@params) - (INST-EA (,tag ,@(map (lambda (p) `(UNQUOTE p)) params)))) + (INST-EA (,tag ,@(map (lambda (p) (list 'UNQUOTE p)) + params)))) (DEFINE-INTEGRABLE (,(symbol-append name '?) EA) (AND (PAIR? EA) (EQ? (CAR EA) ',tag)))))) @@ -442,8 +452,8 @@ USA. environment `(BEGIN ,@(map (lambda (name) - `(DEFINE ,(symbol-append 'TRAP: name) - (INST:TRAP ',name))) + `(DEFINE (,(symbol-append 'TRAP: name) . ARGS) + (APPLY INST:TRAP ',name ARGS))) (cddr form)))))) (define-traps @@ -456,10 +466,21 @@ USA. ;; This group returns; push return address. link conditionally-serialize - interrupt-closure interrupt-dlink interrupt-procedure - interrupt-continuation interrupt-ic-procedure reference-trap safe-reference-trap assignment-trap unassigned?-trap lookup safe-lookup set! unassigned? define unbound? access) + +(define-syntax define-interrupt-tests + (sc-macro-transformer + (lambda (form environment) + environment + `(BEGIN + ,@(map (lambda (name) + `(DEFINE-INST ,(symbol-append 'INTERRUPT-TEST- name))) + (cddr form)))))) + +(define-interrupt-tests + interrupt-test-closure interrupt-test-dynamic-link interrupt-test-procedure + interrupt-test-continuation interrupt-test-ic-procedure) ;;;; Machine registers @@ -601,7 +622,7 @@ USA. (define (lookup-symbolic-operator name error?) (or (hash-table/get symbolic-operators name #f) - (error:bad-range-argument name #f))) + (and error? (error:bad-range-argument name #f)))) (define symbolic-operators (make-strong-eq-hash-table)) diff --git a/src/compiler/machines/svm/compile-assembler.scm b/src/compiler/machines/svm/compile-assembler.scm index f3b3c2c39..47756879c 100644 --- a/src/compiler/machines/svm/compile-assembler.scm +++ b/src/compiler/machines/svm/compile-assembler.scm @@ -2,7 +2,7 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009 Massachusetts Institute of Technology + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -33,6 +33,16 @@ USA. (if (syntax-match? '(* DATUM) (cdr form)) `(,(close-syntax 'QUASIQUOTE environment) ,(cdr form)) (ill-formed-syntax form))))) + + ;; The 20090107 snapshot does not have write-mit-scheme-copyright. + (if (not (environment-bound? environment 'WRITE-MIT-SCHEME-COPYRIGHT)) + (begin + (eval '(define inits '()) environment) + (eval '(define (add-boot-init! thunk) + (set! inits (cons thunk inits))) environment) + (load "../../../runtime/version" environment) + (eval '(for-each (lambda (thunk) (thunk)) inits) environment))) + (load "machine" environment) (load "assembler-runtime" environment) (load "assembler-compiler" environment) diff --git a/src/compiler/machines/svm/compiler.cbf b/src/compiler/machines/svm/compiler.cbf new file mode 100644 index 000000000..1f94efbdb --- /dev/null +++ b/src/compiler/machines/svm/compiler.cbf @@ -0,0 +1,37 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Script to incrementally compile the compiler (from .bins) + +(fluid-let ((compiler:coalescing-constant-warnings? #f)) + (for-each compile-directory + '("back" + "base" + "fggen" + "fgopt" + "machines/svm" + "rtlbase" + "rtlgen" + "rtlopt"))) \ No newline at end of file diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg new file mode 100644 index 000000000..35e23088c --- /dev/null +++ b/src/compiler/machines/svm/compiler.pkg @@ -0,0 +1,756 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Compiler Packaging + +(global-definitions "../runtime/runtime") +(global-definitions "../sf/sf") + +(define-package (compiler) + (files "base/switch" + "base/object" ;tagged object support + "base/enumer" ;enumerations + "base/sets" ;set abstraction + "base/mvalue" ;multiple-value support + "base/scode" ;SCode abstraction + "machines/svm/machine" ;machine dependent stuff + "back/asutl" ;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 + "rtlbase/valclass" ;RTL: value classes + + "back/insseq" ;LAP instruction sequences + ) + (parent ()) + (export () + compiler:analyze-side-effects? + compiler:cache-free-variables? + compiler:coalescing-constant-warnings? + compiler:code-compression? + compiler:compile-by-procedures? + compiler:cross-compiling? + compiler:cse? + compiler:default-top-level-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-floating-point-arithmetic? + 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?) + (import (runtime system-macros) + ucode-primitive + ucode-type) + (import () + (scode/access-components access-components) + (scode/access-environment access-environment) + (scode/access-name access-name) + (scode/access? access?) + (scode/assignment-components assignment-components) + (scode/assignment-name assignment-name) + (scode/assignment-value assignment-value) + (scode/assignment? assignment?) + (scode/combination-components combination-components) + (scode/combination-operands combination-operands) + (scode/combination-operator combination-operator) + (scode/combination? combination?) + (scode/comment-components comment-components) + (scode/comment-expression comment-expression) + (scode/comment-text comment-text) + (scode/comment? comment?) + (scode/conditional-alternative conditional-alternative) + (scode/conditional-components conditional-components) + (scode/conditional-consequent conditional-consequent) + (scode/conditional-predicate conditional-predicate) + (scode/conditional? conditional?) + (scode/constant? scode-constant?) + (scode/declaration-components declaration-components) + (scode/declaration-expression declaration-expression) + (scode/declaration-text declaration-text) + (scode/declaration? declaration?) + (scode/definition-components definition-components) + (scode/definition-name definition-name) + (scode/definition-value definition-value) + (scode/definition? definition?) + (scode/delay-components delay-components) + (scode/delay-expression delay-expression) + (scode/delay? delay?) + (scode/disjunction-alternative disjunction-alternative) + (scode/disjunction-components disjunction-components) + (scode/disjunction-predicate disjunction-predicate) + (scode/disjunction? disjunction?) + (scode/lambda-components lambda-components) + (scode/lambda? lambda?) + (scode/make-access make-access) + (scode/make-assignment make-assignment) + (scode/make-combination make-combination) + (scode/make-comment make-comment) + (scode/make-conditional make-conditional) + (scode/make-declaration make-declaration) + (scode/make-definition make-definition) + (scode/make-delay make-delay) + (scode/make-disjunction make-disjunction) + (scode/make-lambda make-lambda) + (scode/make-open-block make-open-block) + (scode/make-quotation make-quotation) + (scode/make-sequence make-sequence) + (scode/make-the-environment make-the-environment) + (scode/make-unassigned? make-unassigned?) + (scode/make-variable make-variable) + (scode/open-block-components open-block-components) + (scode/open-block? open-block?) + (scode/primitive-procedure? primitive-procedure?) + (scode/procedure? procedure?) + (scode/quotation-expression quotation-expression) + (scode/quotation? quotation?) + (scode/sequence-actions sequence-actions) + (scode/sequence-components sequence-components) + (scode/sequence? sequence?) + (scode/symbol? symbol?) + (scode/the-environment? the-environment?) + (scode/unassigned?-name unassigned?-name) + (scode/unassigned?? unassigned??) + (scode/variable-components variable-components) + (scode/variable-name variable-name) + (scode/variable? variable?))) + +(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 macros) + (files "base/macros") + (parent (compiler)) + (export (compiler) + cfg-node-case + define-enumeration + define-export + define-lvalue + define-pnode + define-root-type + define-rtl-expression + define-rtl-predicate + define-rtl-statement + define-rule + define-rvalue + define-snode + define-vector-slots + descriptor-list + enumeration-case + inst-ea + lap + last-reference + make-lvalue + make-pnode + make-rvalue + make-snode + package + rule-matcher)) + +(define-package (compiler declarations) + (files "machines/svm/decls") + (parent (compiler)) + (export (compiler) + sc + syntax-files!) + (import (scode-optimizer top-level) + sf/internal) + (import (cross-reference) + os-types + read-package-model + pmodel/pathname + pmodel/packages + package/name + package/files) + (initialization (initialize-package!))) + +(define-package (compiler top-level) + (files "base/toplev" + "base/crstop" + "base/asstop") + (parent (compiler)) + (export () + cbf + cf + compile-bin-file + compile-file + compile-file:force? + compile-file:override-usual-integrations + compile-file:sf-only? + compile-procedure + compile-scode + compiler:compiled-code-pathname-type + compiler:reset! + lap->code) + (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* + *external-labels* + label->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-lookup-1 + pattern-variable-name + pattern-variable? + pattern-variables)) + +(define-package (compiler pattern-matcher/parser) + (files "base/pmpars") + (parent (compiler)) + (export (compiler) + make-rule-matcher + parse-rule + rule->matcher + rule-result-expression) + (export (compiler macros) + make-rule-matcher + parse-rule + rule->matcher + 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/svm/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 + rtl:bump-closure) + (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! + add-pre-cse-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 "machines/svm/assembler-runtime" ;ea:*, inst:* procedures + "machines/svm/assembler-db" + "machines/svm/svm1-opcodes" + "back/lapgn1" ;LAP generator + "back/lapgn2" ; " " + "back/lapgn3" ; " " + "back/regmap" ;Hardware register allocator + "machines/svm/lapgen" ;code generation rules + "machines/svm/rules" ; " " " + "back/syntax" ;Generic syntax phase + "back/syerly" ;Early binding version + ) + (parent (compiler)) + (export (compiler) + available-machine-registers + lap-generator/match-rtl-instruction + lap:make-entry-point + lap:make-label-statement + lap:make-unconditional-branch + lap:syntax-instruction) + (export (compiler top-level) + *block-associations* + *interned-assignments* + *interned-constants* + *interned-global-links* + *interned-uuo-links* + *interned-static-variables* + *interned-variables* + *next-constant* + generate-lap) + (import (scode-optimizer expansion) + scode->scode-expander)) + +(define-package (compiler lap-syntaxer map-merger) + (files "back/mermap") + (parent (compiler lap-syntaxer)) + (export (compiler lap-syntaxer) + merge-register-maps)) + +(define-package (compiler lap-syntaxer linearizer) + (files "back/linear") + (parent (compiler lap-syntaxer)) + (export (compiler lap-syntaxer) + add-end-of-block-code! + add-extra-code! + bblock-linearize-lap + extra-code-block/xtra + declare-extra-code-block! + find-extra-code-block + linearize-lap + set-current-branches! + set-extra-code-block/xtra!) + (export (compiler top-level) + *end-of-block-code* + linearize-lap)) + +(define-package (compiler lap-optimizer) + (files "machines/svm/lapopt") + (parent (compiler)) + (export (compiler top-level) + optimize-linear-lap)) + +(define-package (compiler assembler) + (files "back/bitutl" ;Assembly blocks + "back/bittop" ;Assembler top level + ) + (parent (compiler)) + (export (compiler) + instruction-append) + (export (compiler top-level) + assemble)) + +(define-package (compiler disassembler) + (files "machines/svm/disassembler") + (parent (compiler)) + (export () + compiler:write-lap-file + compiler:disassemble) + (import (runtime compiler-info) + compiled-code-block/dbg-info + dbg-info-vector/blocks-vector + dbg-info-vector? + dbg-info/labels + dbg-label/external? + dbg-label/name + dbg-labels/find-offset)) diff --git a/src/compiler/machines/svm/compiler.sf b/src/compiler/machines/svm/compiler.sf new file mode 100644 index 000000000..139f0b50d --- /dev/null +++ b/src/compiler/machines/svm/compiler.sf @@ -0,0 +1,90 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Script to incrementally syntax the compiler + +(load-option 'CREF) + +;; Guarantee that the compiler's package structure exists. +(if (not (name->package '(COMPILER))) + (let ((package-set (package-set-pathname "compiler"))) + (if (not (file-exists? package-set)) + (cref/generate-trivial-constructor "compiler")) + (construct-packages-from-file (fasload package-set)))) + +;; Guarantee that the necessary syntactic transforms and optimizers +;; are loaded. +(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!) + ;; Refer to the cref package model (compiler.pkg) for syntax/load + ;; environments. + (let* ((xref (begin (load-option 'CREF)(->environment '(cross-reference)))) + + ;; Assume there are no os-type-specific files or packages. + (pmodel ((access read-package-model xref) "compiler" 'unix)) + + (env + (lambda (filename) + (->environment + (let ((path (->pathname filename))) + (let loop ((packages ((access pmodel/packages xref) pmodel))) + (if (pair? packages) + (if (find (lambda (f) (pathname=? f path)) + ((access package/files xref) (car packages))) + ((access package/name xref) (car packages)) + (loop (cdr packages))) + (error "No package for file" file))))))) + + (sf-and-load + (lambda files + (for-each (lambda (file) + (fluid-let ((sf/default-syntax-table (env file))) + (sf-conditionally file))) + files) + (for-each (lambda (file) + (load (pathname-new-type file "bin") (env file))) + files)))) + + (fresh-line) + (newline) + (write-string "---- Loading compile-time files ----") + (newline) + (sf-and-load "base/switch") + (sf-and-load "base/macros") + (sf-and-load "machines/svm/decls") + (let ((environment (->environment '(COMPILER DECLARATIONS)))) + ((access initialize-package! environment))) + (sf-and-load "base/pmlook") + (sf-and-load "base/pmpars") + (sf-and-load "machines/svm/machine") + (sf-and-load "back/syntax") + (sf-and-load "base/scode") + (sf-and-load "base/pmerly") + (sf-and-load "back/syerly"))) + +;; Resyntax any files that need it. +((access syntax-files! (->environment '(COMPILER)))) + +;; Rebuild the package constructors and cref. +(cref/generate-constructors "compiler" 'ALL) \ No newline at end of file diff --git a/src/compiler/machines/svm/decls.scm b/src/compiler/machines/svm/decls.scm new file mode 100644 index 000000000..b7c3f4c82 --- /dev/null +++ b/src/compiler/machines/svm/decls.scm @@ -0,0 +1,529 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; 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-nodes '()) + (set! source-hash) + (set! source-nodes/by-rank) + unspecific) + +(define (maybe-setup-source-nodes!) + (if (null? source-nodes) + (setup-source-nodes!))) + +(define (setup-source-nodes!) + + ;; Assume there are no os-specific files or packages. + (define pmodel (read-package-model "compiler" 'unix)) + + (define (all-filenames) + (map enough-namestring + (append-map package/files (pmodel/packages pmodel)))) + + (define (env filename) + (->environment + (let ((path (->pathname filename))) + (let loop ((packages (pmodel/packages pmodel))) + (if (pair? packages) + (if (find (lambda (f) (pathname=? f path)) + (package/files (car packages))) + (package/name (car packages)) + (loop (cdr packages))) + (error "No package for file" file)))))) + + (define (init-packages pmodel) + (let* ((pathname (pmodel/pathname pmodel)) + (package-set (package-set-pathname pathname))) + (if (not (file-exists? package-set)) + (cref/generate-trivial-constructor pathname)) + (construct-packages-from-file (fasload package-set)))) + + (set! source-hash (make-string-hash-table)) + (set! source-nodes + (map (lambda (filename) + (let ((node (make/source-node filename (env filename)))) + (hash-table/put! source-hash filename node) + node)) + (all-filenames))) + (initialize/integration-dependencies!) + (source-nodes/rank!)) + +(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 pathname syntax-table))) + (filename #f read-only #t) + (pathname #f read-only #t) + (syntax-table #f read-only #t) + (forward-links '()) + (backward-links '()) + (forward-closure '()) + (backward-closure '()) + (dependencies '()) + (dependents '()) + (rank #f) + (declarations '()) + (modification-time #f)) + +(define (make/source-node filename syntax-table) + (%make/source-node filename (->pathname filename) syntax-table)) + +(define (filename->source-node filename) + (let ((node (hash-table/get source-hash filename #f))) + (if (not node) + (error "Unknown source file:" filename)) + node)) + +(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) + (write-notification-line + (lambda (port) + (write-string "Source file newer than binary: " port) + (write (source-node/filename node) port)))))) + 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? + (write-notification-line + (lambda (port) + (write-string "Binary file " port) + (write (source-node/filename node) port) + (write-string " newer than dependency " + port) + (write (source-node/filename node*) + port)))) + newer?)))) + (set-source-node/modification-time! node #f)))) + source-nodes) + (for-each + (lambda (node) + (if (not (source-node/modification-time node)) + (for-each (lambda (node*) + (if (source-node/modification-time node*) + (write-notification-line + (lambda (port) + (write-string "Binary file " port) + (write (source-node/filename node*) port) + (write-string " depends on " port) + (write (source-node/filename node) port)))) + (set-source-node/modification-time! node* #f)) + (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-notification-line + (lambda (port) + (write-string "Begin pass 1:" port))) + (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-notification-line + (lambda (port) + (write-string "Begin pass 2:" port))) + (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) + (receive (input-pathname bin-pathname spec-pathname) + (sf/pathname-defaulting (source-node/pathname node) "" #f) + 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-notification-line + (lambda (port) + (write-string "Touch file: " port) + (write (enough-namestring pathname) port))) + (file-touch pathname)))) + +(define (pathname-delete! pathname) + (if (file-exists? pathname) + (begin + (write-notification-line + (lambda (port) + (write-string "Delete file: " port) + (write (enough-namestring pathname) port))) + (delete-file pathname)))) + +(define (sc filename) + (maybe-setup-source-nodes!) + (source-node/syntax! (filename->source-node filename))) + +(define (source-node/syntax! node) + (receive (input-pathname bin-pathname spec-pathname) + (sf/pathname-defaulting (source-node/pathname node) "" #f) + (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?))) + (source-node/declarations node))))) + +(define (modification-time node type) + (file-modification-time + (pathname-new-type (source-node/pathname node) type))) + +;;;; 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")) + (machine-base + (append (filename/append "machines/svm" "machine") + (filename/append "back" "asutl"))) + (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/svm" + "machine")) + (lapgen-base + (append (filename/append "back" "linear" "regmap") + (filename/append "machines/svm" + "assembler-runtime" "svm1-opcodes" + "lapgen"))) + (lapgen-body + (append + (filename/append "back" "lapgn1" "lapgn2" "syntax") + (filename/append "machines/svm" "rules")))) + + (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 "machines/svm" "machine" "back" "asutl") + (define-integration-dependencies "base" "object" "base" "enumer") + (define-integration-dependencies "base" "enumer" "base" "object") + (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") + (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/svm" "machine" "rtlbase" + "rtlreg" "rtlty1" "rtlty2") + + (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2") + (define-integration-dependencies "rtlbase" "rgraph" "machines/svm" + "machine") + (define-integration-dependencies "rtlbase" "rtlcfg" "base" + "cfg1" "cfg2" "cfg3") + (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils") + (define-integration-dependencies "rtlbase" "rtlcon" "machines/svm" + "machine") + (file-dependency/integration/join (filename/append "rtlbase" "rtlcon") + rtl-base) + (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/svm" + "machine") + (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase" + "rgraph" "rtlty1") + (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg") + (define-integration-dependencies "rtlbase" "rtlty2" "machines/svm" + "machine") + (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 machine-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 machine-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/svm" "rules")) + (append machine-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" "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) + + (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" "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 + #f + #f + (cons 'RELATIVE + (make-list + (length (cdr (pathname-directory pathname))) + 'UP)) + #f + #f + #f))) + (lambda (pathname) + (merge-pathnames pathname default))) + integration-dependencies))) + +(define (integration-declaration? declaration) + (eq? (car declaration) 'INTEGRATE-EXTERNAL)) \ No newline at end of file diff --git a/src/compiler/machines/svm/lapgen.scm b/src/compiler/machines/svm/lapgen.scm index bd4736132..a57cb2e4c 100644 --- a/src/compiler/machines/svm/lapgen.scm +++ b/src/compiler/machines/svm/lapgen.scm @@ -2,7 +2,7 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009 Massachusetts Institute of Technology + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -65,7 +65,8 @@ USA. (LAP) (begin (guarantee-registers-compatible source target) - (inst:copy (register-reference target) + (inst:copy (register-type target) + (register-reference target) (register-reference source))))) (define (reference->register-transfer source target) @@ -80,7 +81,7 @@ USA. (inst:load 'WORD (register-reference target) (pseudo-register-home source))) (define (register->home-transfer source target) - (inst:store 'WORD (register-reference target) (pseudo-register-home target))) + (inst:store 'WORD (register-reference source) (pseudo-register-home target))) ;;;; Linearizer interface @@ -95,9 +96,6 @@ USA. (LAP ,@(inst:entry-point label) ,@(make-expression-label label))) -(define (make-expression-label label) - (make-external-label label 'EXPRESSION)) - (define (make-external-label label type-code) (set! *external-labels* (cons label *external-labels*)) (LAP ,@(inst:datum-u16 type-code) @@ -121,6 +119,7 @@ USA. (make-external-label label (encode-continuation-offset label #xFFFE))) (define (make-continuation-label entry-label label) + entry-label (make-external-label label (encode-continuation-offset label #xFFFD))) (define (encode-procedure-type n-required n-optional rest?) @@ -157,7 +156,7 @@ USA. (else (error:bad-range-argument object 'LOAD-CONSTANT)))) -(define (simple-branches! condition source1 #!default source2) +(define (simple-branches! condition source1 #!optional source2) (if (default-object? source2) (set-current-branches! (lambda (label) -- 2.25.1