#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.3 1987/12/31 10:01:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.4 1988/03/14 20:24:11 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(and value
(or (rvalue/constant? value)
(and (rvalue/procedure? value)
- (procedure/open? value))))))
+ (procedure/open? value)
+#|
+ ;; For now this is disabled.
+ ;; We need self-consistent closing
+ (or (procedure/open? value)
+ (and (procedure/closure? value)
+ (procedure/trivial-closure? value)))
+|#
+ )))))
\f
(define (lvalue=? lvalue lvalue*)
(or (eq? lvalue lvalue*)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.2 1987/12/30 06:59:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.3 1988/03/14 20:24:24 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
closure-block ;for closure, where procedure is closed [block]
closure-offset ;for closure, offset of procedure in stack frame
register ;for continuation, argument register
+ closure-size ;for closure, virtual size of frame [integer or false]
)
(define *procedures*)
(node->edge (cfg-entry-node scfg))
(list-copy required) (list-copy optional) rest
(generate-label name) false false false false false
- false)))
+ false false)))
(set! *procedures* (cons procedure *procedures*))
(set-block-procedure! block procedure)
procedure))
(procedure-closing-block procedure))))
\f
(define-integrable (closure-procedure-needs-operator? procedure)
- ;; **** When implemented, this must be true if the closure needs its
- ;; parent frame since the parent frame is stored in the operator.
- true)
+ ;; This must be true if the closure needs its parent frame since the
+ ;; parent frame is found from the operator. Currently only avoided
+ ;; for trivial closures.
+ (not (procedure/trivial-closure? procedure)))
(define (procedure-interface-optimizible? procedure)
(and (stack-block? (procedure-block procedure))
(define-integrable (procedure/closure? procedure)
(procedure-closure-block procedure))
+(define-integrable (procedure/trivial-closure? procedure)
+ (let ((enclosing (procedure-closing-block procedure)))
+ (or (null? enclosing)
+ (and (ic-block? enclosing)
+ (not (ic-block/use-lookup? enclosing))))))
+
(define (procedure/closed? procedure)
(or (procedure/ic? procedure)
(procedure/closure? procedure)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.2 1987/12/30 06:59:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.3 1988/03/14 20:24:41 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define compiler:show-subphases? false)
(define compiler:preserve-data-structures? false)
(define compiler:code-compression? true)
+(define compiler:compile-once-only-packages-recursively? true)
(define compiler:cache-free-variables? true)
(define compiler:implicit-self-static? false)
(define compiler:cse? true)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.4 1988/02/19 20:56:49 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.5 1988/03/14 20:24:54 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(and compiler:generate-rtl-files?
(pathname-new-type output-pathname "brtl"))
(pathname-new-type output-pathname "binf")))))
+\f
+;;;; Utilities for compiling in batch mode
+
+(define compiler:batch-mode? false)
+(define compiler:abort-handled? false)
+(define compiler:abort-continuation)
(define (compiler:batch-compile input #!optional output)
- (fluid-let (((access *error-hook* error-system)
+ (fluid-let ((compiler:batch-mode? true)
+ ((access *error-hook* error-system)
(lambda (env mesg irr subst?)
- (newline)
- (display "*** Error: ")
- (display mesg)
- (display " ***")
- (newline)
- (display "Irritant: ")
- (write irr)
- (compiler:abort false))))
+ (if compiler:abort-handled?
+ (begin
+ (newline)
+ (newline)
+ (display "*** Error: ")
+ (display mesg)
+ (display " ***")
+ (newline)
+ (display "Irritant: ")
+ (write irr)
+ (compiler:abort false))
+ ((access standard-error-hook error-system)
+ env mesg irr subst?)))))
(if (unassigned? output)
(compile-bin-file input)
(compile-bin-file input output))))
-\f
-;;; Utilities for compiling in batch mode
-
-(define compiler:abort-handled? false)
-(define compiler:abort-continuation)
(define (compiler:abort value)
(if compiler:abort-handled?
(begin
(newline)
- (newline)
- (display " Aborting...")
+ (display "*** Aborting...")
(compiler:abort-continuation value))
(error "compiler:abort: Not set up to abort" value)))
-(define (compiler-process transform input-pathname output-pathname)
- (call-with-current-continuation
- (lambda (abort-compilation)
- (fluid-let ((compiler:abort-continuation abort-compilation)
- (compiler:abort-handled? true))
- (fasdump (transform input-pathname output-pathname)
- output-pathname)))))
+(define (batch-kernel real-kernel)
+ (lambda (input-string)
+ (call-with-current-continuation
+ (lambda (abort-compilation)
+ (fluid-let ((compiler:abort-continuation abort-compilation)
+ (compiler:abort-handled? true))
+ (real-kernel input-string))))))
\f
(define (compiler-pathnames input-string output-string default transform)
- (let ((kernel
- (lambda (input-string)
- (let ((input-pathname
- (pathname->input-truename
- (merge-pathnames (->pathname input-string) default))))
- (if (not input-pathname)
- (error "File does not exist" input-string))
- (let ((output-pathname
- (let ((output-pathname
- (pathname-new-type input-pathname "com")))
- (if output-string
- (merge-pathnames (->pathname output-string)
- output-pathname)
- output-pathname))))
- (newline)
- (write-string "Compile File: ")
- (write (pathname->string input-pathname))
- (write-string " => ")
- (write (pathname->string output-pathname))
- (compiler-process transform input-pathname output-pathname))))))
+ (let* ((core
+ (lambda (input-string)
+ (let ((input-pathname
+ (pathname->input-truename
+ (merge-pathnames (->pathname input-string) default))))
+ (if (not input-pathname)
+ (error "File does not exist" input-string))
+ (let ((output-pathname
+ (let ((output-pathname
+ (pathname-new-type input-pathname "com")))
+ (if output-string
+ (merge-pathnames (->pathname output-string)
+ output-pathname)
+ output-pathname))))
+ (newline)
+ (write-string "Compile File: ")
+ (write (pathname->string input-pathname))
+ (write-string " => ")
+ (write (pathname->string output-pathname))
+ (fasdump (transform input-pathname output-pathname)
+ output-pathname)))))
+ (kernel
+ (if compiler:batch-mode?
+ (batch-kernel core)
+ core)))
(if (pair? input-string)
(for-each kernel input-string)
(kernel input-string))))
(compiler-phase "Linearizing BITs"
(lambda ()
(set! compiler:bits
- (LAP ,@(lap:make-entry-point compiler:entry-label
- compiler:block-label)
- ,@((access linearize-bits lap-syntax-package)
- (if compiler:preserve-data-structures?
- *rtl-graphs*
- (set! *rtl-graphs*))))))))
+ (append-instruction-sequences!
+ (lap:make-entry-point compiler:entry-label
+ compiler:block-label)
+ ((access linearize-bits lap-syntax-package)
+ (if compiler:preserve-data-structures?
+ *rtl-graphs*
+ (set! *rtl-graphs*))))))))
(define (phase/assemble)
(compiler-phase "Assembling"
(with-interrupt-mask interrupt-mask-none
(lambda (old)
((ucode-primitive &make-object)
- type-code:compiled-expression
+ type-code:compiled-entry
(make-non-pointer-object
(+ (cdr (or (assq label compiler:label-bindings)
(error "Missing entry point" label)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.2 1987/12/30 06:56:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.3 1988/03/14 20:25:13 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-type-code procedure)
(define-type-code extended-procedure)
(define-type-code cell)
- (define-type-code compiled-expression)
- (define-type-code compiler-link)
- (define-type-code compiled-procedure)
(define-type-code environment)
+ (define-type-code unassigned)
(define-type-code stack-environment)
- (define-type-code return-address compiler-return-address)
- (define-type-code unassigned))
+ (define-type-code compiled-entry))
(define (scode/procedure-type-code *lambda)
(cond ((primitive-type? type-code:lambda *lambda)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.2 1988/01/06 18:30:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.3 1988/03/14 20:23:52 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(rank false))
(define source-filenames
- (mapcan (lambda (subdirectory)
- (map (lambda (pathname)
- (string-append subdirectory "/" (pathname-name pathname)))
- (directory-read (string-append subdirectory "/*.bin"))))
- '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
- "machines/bobcat")))
+ (let ((load-env (the-environment)))
+ (mapcan (lambda (subdirectory)
+ (map (lambda (pathname)
+ (string-append subdirectory "/" (pathname-name pathname)))
+ (directory-read
+ (string-append
+ subdirectory
+ (if (lexical-unbound? load-env
+ 'SOURCE-FILE-EXPRESSION)
+ "/*.bin"
+ source-file-expression)))))
+ '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
+ "machines/bobcat"))))
(define source-hash
(make/hash-table 101
projects / mit-scheme.git / commitdiff