# 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.
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
--- /dev/null
+assembler-db.scm
+assembler-rules.exp
+svm1-defns.h
+svm1-opcodes.scm
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.
(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)))
(newline port))
\f
(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)
(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)))
`(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))
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.
;;; machine instructions, which are distinguished by an opcode byte.
(define-record-type <rt-coding-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
;;; **** 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)
(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)))
(define-integrable (pvar-name pv) (cadr pv))
(define-integrable (pvar-type pv) (caddr pv))
\f
-(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) '_)
(let ((instance
(match-rt-coding-type (pvar-type pattern)
expression
- coding-types
symbol-table)))
(and instance
(cons instance pvals)))))
(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))))))
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
;; 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)
\f
;;;; Machine registers
(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))
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.
(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)
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
+\f
+(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?)))
+\f
+(define-package (compiler reference-contexts)
+ (files "base/refctx")
+ (parent (compiler))
+ (export (compiler)
+ add-reference-context/adjacent-parents!
+ initialize-reference-contexts!
+ make-reference-context
+ modify-reference-contexts!
+ reference-context/adjacent-parent?
+ reference-context/block
+ reference-context/offset
+ reference-context/procedure
+ reference-context?
+ set-reference-context/offset!))
+
+(define-package (compiler 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?*))
+\f
+(define-package (compiler debug)
+ (files "base/debug")
+ (parent (compiler))
+ (export ()
+ debug/find-continuation
+ debug/find-entry-node
+ debug/find-procedure
+ debug/where
+ dump-rtl
+ po
+ show-bblock-rtl
+ show-fg
+ show-fg-node
+ show-rtl
+ write-rtl-instructions)
+ (import (runtime pretty-printer)
+ *pp-primitives-by-name*)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
+
+(define-package (compiler pattern-matcher/lookup)
+ (files "base/pmlook")
+ (parent (compiler))
+ (export (compiler)
+ make-pattern-variable
+ pattern-lookup
+ pattern-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))
+\f
+(define-package (compiler debugging-information)
+ (files "base/infnew")
+ (parent (compiler))
+ (export (compiler top-level)
+ info-generation-phase-1
+ info-generation-phase-2
+ info-generation-phase-3)
+ (export (compiler rtl-generator)
+ generated-dbg-continuation)
+ (import (runtime compiler-info)
+ make-dbg-info
+
+ make-dbg-expression
+ dbg-expression/block
+ dbg-expression/label
+ set-dbg-expression/label!
+
+ make-dbg-procedure
+ dbg-procedure/block
+ dbg-procedure/label
+ set-dbg-procedure/label!
+ dbg-procedure/name
+ dbg-procedure/required
+ dbg-procedure/optional
+ dbg-procedure/rest
+ dbg-procedure/auxiliary
+ dbg-procedure/external-label
+ set-dbg-procedure/external-label!
+ dbg-procedure<?
+
+ make-dbg-continuation
+ dbg-continuation/block
+ dbg-continuation/label
+ set-dbg-continuation/label!
+ dbg-continuation<?
+
+ make-dbg-block
+ dbg-block/parent
+ dbg-block/layout
+ dbg-block/stack-link
+ set-dbg-block/procedure!
+
+ make-dbg-variable
+ dbg-variable/value
+ set-dbg-variable/value!
+
+ dbg-block-name/dynamic-link
+ dbg-block-name/ic-parent
+ dbg-block-name/normal-closure
+ dbg-block-name/return-address
+ dbg-block-name/static-link
+
+ make-dbg-label-2
+ dbg-label/offset
+ set-dbg-label/external?!))
+
+(define-package (compiler constraints)
+ (files "base/constr")
+ (parent (compiler))
+ (export (compiler)
+ make-constraint
+ constraint/element
+ constraint/graph-head
+ constraint/afters
+ constraint/closed?
+ constraint-add!
+ add-constraint-element!
+ add-constraint-set!
+ make-constraint-graph
+ constraint-graph/entry-nodes
+ constraint-graph/closed?
+ close-constraint-graph!
+ close-constraint-node!
+ order-per-constraints
+ order-per-constraints/extracted
+ legal-ordering-per-constraints?
+ with-new-constraint-marks
+ constraint-marked?
+ constraint-mark!
+ transitively-close-dag!
+ reverse-postorder))
+\f
+(define-package (compiler fg-generator)
+ (files "fggen/canon" ;SCode canonicalizer
+ "fggen/fggen" ;SCode->flow-graph converter
+ "fggen/declar" ;Declaration handling
+ )
+ (parent (compiler))
+ (export (compiler top-level)
+ canonicalize/top-level
+ construct-graph)
+ (import (runtime scode-data)
+ &pair-car
+ &pair-cdr
+ &triple-first
+ &triple-second
+ &triple-third))
+
+(define-package (compiler fg-optimizer)
+ (files "fgopt/outer" ;outer analysis
+ "fgopt/sideff" ;side effect analysis
+ )
+ (parent (compiler))
+ (export (compiler top-level)
+ clear-call-graph!
+ compute-call-graph!
+ outer-analysis
+ side-effect-analysis))
+
+(define-package (compiler fg-optimizer fold-constants)
+ (files "fgopt/folcon")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) fold-constants))
+
+(define-package (compiler fg-optimizer operator-analysis)
+ (files "fgopt/operan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) operator-analysis))
+
+(define-package (compiler fg-optimizer variable-indirection)
+ (files "fgopt/varind")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) initialize-variable-indirections!))
+
+(define-package (compiler fg-optimizer environment-optimization)
+ (files "fgopt/envopt")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) optimize-environments!))
+
+(define-package (compiler fg-optimizer closure-analysis)
+ (files "fgopt/closan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) identify-closure-limits!))
+
+(define-package (compiler fg-optimizer continuation-analysis)
+ (files "fgopt/contan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level)
+ continuation-analysis
+ setup-block-static-links!))
+
+(define-package (compiler fg-optimizer compute-node-offsets)
+ (files "fgopt/offset")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) compute-node-offsets))
+\f
+(define-package (compiler fg-optimizer connectivity-analysis)
+ (files "fgopt/conect")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) connectivity-analysis))
+
+(define-package (compiler fg-optimizer delete-integrated-parameters)
+ (files "fgopt/delint")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) delete-integrated-parameters))
+
+(define-package (compiler fg-optimizer design-environment-frames)
+ (files "fgopt/desenv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) design-environment-frames!))
+
+(define-package (compiler fg-optimizer setup-block-types)
+ (files "fgopt/blktyp")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level)
+ setup-block-types!
+ setup-closure-contexts!)
+ (export (compiler)
+ indirection-block-procedure))
+
+(define-package (compiler fg-optimizer simplicity-analysis)
+ (files "fgopt/simple")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) simplicity-analysis)
+ (export (compiler fg-optimizer subproblem-ordering)
+ new-subproblem/compute-simplicity!))
+
+(define-package (compiler fg-optimizer simulate-application)
+ (files "fgopt/simapp")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) simulate-application))
+
+(define-package (compiler fg-optimizer subproblem-free-variables)
+ (files "fgopt/subfre")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) compute-subproblem-free-variables)
+ (export (compiler fg-optimizer) map-union)
+ (export (compiler fg-optimizer subproblem-ordering)
+ new-subproblem/compute-free-variables!))
+
+(define-package (compiler fg-optimizer subproblem-ordering)
+ (files "fgopt/order")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) subproblem-ordering))
+
+(define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
+ (files "fgopt/reord" "fgopt/reuse")
+ (parent (compiler fg-optimizer subproblem-ordering))
+ (export (compiler top-level) setup-frame-adjustments)
+ (export (compiler fg-optimizer subproblem-ordering)
+ order-subproblems/maybe-overwrite-block))
+
+(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
+ (files "fgopt/param")
+ (parent (compiler fg-optimizer subproblem-ordering))
+ (export (compiler fg-optimizer subproblem-ordering)
+ parameter-analysis))
+
+(define-package (compiler fg-optimizer return-equivalencing)
+ (files "fgopt/reteqv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) find-equivalent-returns!))
+\f
+(define-package (compiler rtl-generator)
+ (files "rtlgen/rtlgen" ;RTL generator
+ "rtlgen/rgstmt" ;statements
+ "rtlgen/fndvar" ;find variables
+ "machines/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))
+\f
+(define-package (compiler rtl-cse)
+ (files "rtlopt/rcse1" ;RTL common subexpression eliminator
+ "rtlopt/rcse2"
+ "rtlopt/rcseep" ;CSE expression predicates
+ "rtlopt/rcseht" ;CSE hash table
+ "rtlopt/rcserq" ;CSE register/quantity abstractions
+ "rtlopt/rcsesr" ;CSE stack references
+ )
+ (parent (compiler))
+ (export (compiler top-level) common-subexpression-elimination))
+
+(define-package (compiler rtl-optimizer)
+ (files "rtlopt/rdebug")
+ (parent (compiler)))
+
+(define-package (compiler rtl-optimizer invertible-expression-elimination)
+ (files "rtlopt/rinvex")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) invertible-expression-elimination))
+
+(define-package (compiler rtl-optimizer common-suffix-merging)
+ (files "rtlopt/rtlcsm")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) merge-common-suffixes!))
+
+(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
+ (files "rtlopt/rdflow")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) rtl-dataflow-analysis))
+
+(define-package (compiler rtl-optimizer rtl-rewriting)
+ (files "rtlopt/rerite")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level)
+ rtl-rewriting:post-cse
+ rtl-rewriting:pre-cse)
+ (export (compiler lap-syntaxer)
+ add-rewriting-rule!
+ 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))
+\f
+(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))
--- /dev/null
+#| -*-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
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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))
+\f
+(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)))))
+\f
+;;;; Rank
+
+(define (source-nodes/rank!)
+ (compute-dependencies! source-nodes)
+ (compute-ranks! source-nodes)
+ (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
+ unspecific)
+
+(define (compute-dependencies! nodes)
+ (for-each (lambda (node)
+ (set-source-node/dependencies!
+ node
+ (list-transform-negative (source-node/backward-closure node)
+ (lambda (node*)
+ (memq node (source-node/backward-closure node*)))))
+ (set-source-node/dependents!
+ node
+ (list-transform-negative (source-node/forward-closure node)
+ (lambda (node*)
+ (memq node (source-node/forward-closure node*))))))
+ nodes))
+
+(define (compute-ranks! nodes)
+ (let loop ((nodes nodes) (unranked-nodes '()))
+ (if (null? nodes)
+ (if (not (null? unranked-nodes))
+ (loop unranked-nodes '()))
+ (loop (cdr nodes)
+ (let ((node (car nodes)))
+ (let ((rank (source-node/rank* node)))
+ (if rank
+ (begin
+ (set-source-node/rank! node rank)
+ unranked-nodes)
+ (cons node unranked-nodes))))))))
+
+(define (source-node/rank* node)
+ (let loop ((nodes (source-node/dependencies node)) (rank -1))
+ (if (null? nodes)
+ (1+ rank)
+ (let ((rank* (source-node/rank (car nodes))))
+ (and rank*
+ (loop (cdr nodes) (max rank rank*)))))))
+
+(define (source-nodes/sort-by-rank nodes)
+ (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
+\f
+;;;; File Syntaxer
+
+(define (syntax-files!)
+ (maybe-setup-source-nodes!)
+ (for-each
+ (lambda (node)
+ (let ((modification-time
+ (let ((source (modification-time node "scm"))
+ (binary (modification-time node "bin")))
+ (if (not source)
+ (error "Missing source file" (source-node/filename node)))
+ (and binary (< source binary) binary))))
+ (set-source-node/modification-time! node modification-time)
+ (if (not modification-time)
+ (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))))
+\f
+(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)))
+\f
+;;;; Integration Dependencies
+
+(define (initialize/integration-dependencies!)
+
+ (define (add-declaration! declaration filenames)
+ (for-each (lambda (filenames)
+ (let ((node (filename->source-node filenames)))
+ (set-source-node/declarations!
+ node
+ (cons declaration
+ (source-node/declarations node)))))
+ filenames))
+
+ (let* ((front-end-base
+ (filename/append "base"
+ "blocks" "cfg1" "cfg2" "cfg3"
+ "contin" "ctypes" "enumer" "lvalue"
+ "object" "proced" "rvalue"
+ "scode" "subprb" "utils"))
+ (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
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.
(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)
(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)))
\f
;;;; Linearizer interface
(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)
(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?)
(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)
projects / mit-scheme.git / commitdiff