to avoid static links in cases where they were in fact needed.
Add a few missing code generation rules.
Make the compiler print its phase information in a nicer format.
Add a few top level utilities:
- cf (SFs your file first)
- compiler:batch-compile (not exported). In case of error it prints
the error information and aborts the current compilation, thus when
compiling multiple files (ie. compiling the compiler) it will continue
with the next one.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.7 1988/02/17 19:12:25 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.8 1988/02/19 20:57:27 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(lambda ()
(initial-phase (instruction-sequence->directives input)))
(lambda (directives vars)
- (relax! directives vars)
- (let ((code-block (final-phase directives)))
- (values code-block
+ (let* ((count (relax! directives vars))
+ (code-block (final-phase directives)))
+ (values count
+ code-block
(queue->list *entry-points*)
(symbol-table->assq-list *the-symbol-table*)
(queue->list *linkage-info*)))))))
linker))
(define (relax! directives vars)
- (define (tension-message count)
- (newline)
- (display "assemble: Branch tensioning done in ")
- (write (1+ count))
- (if (zero? count)
- (display " iteration.")
- (display " iterations.")))
-
(define (loop vars count)
(finish-symbol-table!)
(if (null? vars)
- (tension-message count)
+ count
(with-values (lambda () (phase-2 vars))
(lambda (any-modified? number-of-vars)
(if any-modified?
(clear-symbol-table!)
(initialize-symbol-table!)
(loop (phase-1 directives) (1+ count)))
- (tension-message count))))))
+ count)))))
(loop vars 0))
\f
;;;; Output block generation
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.3 1987/12/30 09:09:57 cph Exp $
+$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 $
Copyright (c) 1987 Massachusetts Institute of Technology
compiler:real-time)
value)))
\f
+;;;; The file compiler, its usual mode.
+
+(define (cf input #!optional output)
+ (let ((kernel
+ (lambda (source-file)
+ (let ((scode-file
+ (merge-pathnames
+ (make-pathname false false false "bin" false)
+ (->pathname source-file))))
+ ;; Maybe this should be done only if scode-file
+ ;; does not exist or is older than source-file.
+ (sf source-file scode-file)
+ (newline)
+ (if (unassigned? output)
+ (compile-bin-file scode-file)
+ (compile-bin-file scode-file output))))))
+ (if (pair? input)
+ (for-each kernel input)
+ (kernel input))))
+
(define (compile-bin-file input-string #!optional output-string)
(compiler-pathnames input-string
(and (not (unassigned? output-string)) output-string)
(pathname-new-type output-pathname "brtl"))
(pathname-new-type output-pathname "binf")))))
+(define (compiler:batch-compile input #!optional output)
+ (fluid-let (((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 (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...")
+ (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)))))
+\f
(define (compiler-pathnames input-string output-string default transform)
(let ((kernel
(lambda (input-string)
(write (pathname->string input-pathname))
(write-string " => ")
(write (pathname->string output-pathname))
- (fasdump (transform input-pathname output-pathname)
- output-pathname))))))
+ (compiler-process transform input-pathname output-pathname))))))
(if (pair? input-string)
(for-each kernel input-string)
(kernel input-string))))
(compiler-phase/invisible thunk)))
(define (compiler-phase/visible name thunk)
- (write-line name)
+ (newline)
+ (display " ")
+ (display name)
+ (display "...")
(let ((process-start (process-time-clock))
(real-start (real-time-clock)))
(thunk)
(real-delta (- (real-time-clock) real-start)))
(set! compiler:process-time (+ process-delta compiler:process-time))
(set! compiler:real-time (+ real-delta compiler:real-time))
- (compiler-time-report "Time taken" process-delta real-delta))))
+ (compiler-time-report " Time taken" process-delta real-delta))))
(define (compiler-phase/invisible thunk)
(if compiler:phase-wrapper
(SET! ,name)))
\f
(define (phase/fg-generation)
- (compiler-phase 'FG-GENERATION
+ (compiler-phase "Generating the Flow Graph"
(lambda ()
(set! *current-label-number* 0)
(set! *constants* '())
(set! *expressions*))))
(define (phase/fg-optimization)
- (compiler-superphase 'FG-OPTIMIZATION
+ (compiler-superphase "Optimizing the Flow Graph"
(lambda ()
(phase/simulate-application)
(phase/outer-analysis)
(phase/fg-optimization-cleanup))))
(define (phase/simulate-application)
- (compiler-subphase 'SIMULATE-APPLICATION
+ (compiler-subphase "Simulating Applications"
(lambda ()
((access simulate-application fg-optimizer-package)
*lvalues*
*applications*))))
\f
(define (phase/outer-analysis)
- (compiler-subphase 'OUTER-ANALYSIS
+ (compiler-subphase "Outer Analysis"
(lambda ()
((access outer-analysis fg-optimizer-package)
*root-expression*
*applications*))))
(define (phase/fold-constants)
- (compiler-subphase 'FOLD-CONSTANTS
+ (compiler-subphase "Constant Folding"
(lambda ()
((access fold-constants fg-optimizer-package)
*lvalues*
*applications*))))
(define (phase/open-coding-analysis)
- (compiler-subphase 'OPEN-CODING-ANALYSIS
+ (compiler-subphase "Open Coding Analysis"
(lambda ()
((access open-coding-analysis rtl-generator-package)
*applications*))))
(define (phase/operator-analysis)
- (compiler-subphase 'OPERATOR-ANALYSIS
+ (compiler-subphase "Operator Analysis"
(lambda ()
((access operator-analysis fg-optimizer-package)
*procedures*
*applications*))))
(define (phase/identify-closure-limits)
- (compiler-subphase 'IDENTIFY-CLOSURE-LIMITS
+ (compiler-subphase "Identifying Closure Limits"
(lambda ()
((access identify-closure-limits! fg-optimizer-package)
*procedures*
*assignments*))))
(define (phase/setup-block-types)
- (compiler-subphase 'SETUP-BLOCK-TYPES
+ (compiler-subphase "Setting Up Block Types"
(lambda ()
((access setup-block-types! fg-optimizer-package)
*root-block*))))
(define (phase/continuation-analysis)
- (compiler-subphase 'CONTINUATION-ANALYSIS
+ (compiler-subphase "Continuation Analysis"
(lambda ()
((access continuation-analysis fg-optimizer-package)
*blocks*))))
(define (phase/simplicity-analysis)
- (compiler-subphase 'SIMPLICITY-ANALYSIS
+ (compiler-subphase "Simplicity Analysis"
(lambda ()
((access simplicity-analysis fg-optimizer-package)
*parallels*))))
\f
(define (phase/subproblem-ordering)
- (compiler-subphase 'SUBPROBLEM-ORDERING
+ (compiler-subphase "Ordering Subproblems"
(lambda ()
((access subproblem-ordering fg-optimizer-package)
*parallels*))))
(define (phase/connectivity-analysis)
- (compiler-subphase 'CONNECTIVITY-ANALYSIS
+ (compiler-subphase "Connectivity Analysis"
(lambda ()
((access connectivity-analysis fg-optimizer-package)
*root-expression*
*procedures*))))
(define (phase/design-environment-frames)
- (compiler-subphase 'DESIGN-ENVIRONMENT-FRAMES
+ (compiler-subphase "Designing Environment Frames"
(lambda ()
((access design-environment-frames! fg-optimizer-package)
*blocks*))))
(define (phase/compute-node-offsets)
- (compiler-subphase 'COMPUTE-NODE-OFFSETS
+ (compiler-subphase "Computing Node Offsets"
(lambda ()
((access compute-node-offsets fg-optimizer-package)
*root-expression*))))
(define (phase/fg-optimization-cleanup)
- (compiler-subphase 'FG-OPTIMIZATION-CLEANUP
+ (compiler-subphase "Cleaning Up After Flow Graph Optimization"
(lambda ()
(if (not compiler:preserve-data-structures?)
(begin (set! *constants*)
(set! *root-block*))))))
\f
(define (phase/rtl-generation)
- (compiler-phase 'RTL-GENERATION
+ (compiler-phase "Generating RTL"
(lambda ()
(set! *rtl-procedures* '())
(set! *rtl-continuations* '())
number-of-machine-registers))
*rtl-graphs*)))
(newline)
- (write-string "Registers used: ")
+ (write-string " Registers used: ")
(write (apply max n-registers))
(write-string " max, ")
(write (apply min n-registers))
(write-string " mean")))))
(define (phase/rtl-optimization)
- (compiler-superphase 'RTL-OPTIMIZATION
+ (compiler-superphase "Optimizing RTL"
(lambda ()
(if compiler:cse?
(phase/common-subexpression-elimination))
(phase/rtl-optimization-cleanup))))
(define (phase/common-subexpression-elimination)
- (compiler-subphase 'COMMON-SUBEXPRESSION-ELIMINATION
+ (compiler-subphase "Eliminating Common Subexpressions"
(lambda ()
((access common-subexpression-elimination rtl-cse-package)
*rtl-graphs*))))
\f(define (phase/lifetime-analysis)
- (compiler-subphase 'LIFETIME-ANALYSIS
+ (compiler-subphase "Lifetime Analysis"
(lambda ()
((access lifetime-analysis rtl-optimizer-package) *rtl-graphs*))))
(define (phase/code-compression)
- (compiler-subphase 'CODE-COMPRESSION
+ (compiler-subphase "Code Compression"
(lambda ()
((access code-compression rtl-optimizer-package) *rtl-graphs*))))
(define (phase/rtl-file-output pathname)
- (compiler-phase 'RTL-FILE-OUTPUT
+ (compiler-phase "RTL File Output"
(lambda ()
(fasdump ((access linearize-rtl rtl-generator-package) *rtl-graphs*)
pathname))))
(define (phase/register-allocation)
- (compiler-subphase 'REGISTER-ALLOCATION
+ (compiler-subphase "Allocating Registers"
(lambda ()
((access register-allocation rtl-optimizer-package) *rtl-graphs*))))
*rtl-graphs*)))
(define (phase/bit-generation)
- (compiler-phase 'BIT-GENERATION
+ (compiler-phase "Generating BITs"
(lambda ()
(set! compiler:external-labels '())
((access generate-bits lap-syntax-package)
(set! *rtl-continuations*))))))
\f
(define (phase/bit-linearization)
- (compiler-phase 'BIT-LINEARIZATION
+ (compiler-phase "Linearizing BITs"
(lambda ()
(set! compiler:bits
(LAP ,@(lap:make-entry-point compiler:entry-label
(set! *rtl-graphs*))))))))
(define (phase/assemble)
- (compiler-phase 'ASSEMBLE
+ (compiler-phase "Assembling"
(lambda ()
(if compiler:preserve-data-structures?
((access assemble bit-package)
(set! compiler:bits)
phase/assemble-finish)))))
-(define (phase/assemble-finish code-vector labels bindings linkage-info)
+(define (phase/assemble-finish count code-vector labels bindings linkage-info)
(set! compiler:code-vector code-vector)
(set! compiler:entry-points labels)
- (set! compiler:label-bindings bindings))
+ (set! compiler:label-bindings bindings)
+ (newline)
+ (display " Branch tensioning done in ")
+ (write (1+ count))
+ (if (zero? count)
+ (display " iteration.")
+ (display " iterations.")))
(define (phase/info-generation-2 pathname)
- (compiler-phase 'DEBUGGING-INFO-GENERATION-2
+ (compiler-phase "Generating Debugging Information (pass 2)"
(lambda ()
(fasdump ((access generation-phase2 debugging-information-package)
compiler:label-bindings
(pathname->string pathname)))))
\f
(define (phase/link)
- (compiler-phase 'LINK
+ (compiler-phase "Linking"
(lambda ()
;; This has sections locked against GC since the code may not be
;; purified.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.3 1988/01/04 13:13:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.4 1988/02/19 20:58:57 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(package (continuation-analysis)
+;;;; Continuation Analysis
+
+;;; Determine when static or dynamic links are to be used.
-;;; Determine when static or dynamic links are to be used. For static
-;;; links, we compute the `block-stack-link' which is the set of
-;;; blocks which might be immediately adjacent (away from the top of
-;;; the stack) to the given block on the stack. If it is possible to
-;;; find the parent in a consistent way with any one of these adjacent
-;;; blocks, we do not need a static link. Otherwise, we set
+;;; Static links:
+
+;;; We compute the `block-stack-link' which is the set of blocks which
+;;; might be immediately adjacent (away from the top of the stack) to
+;;; the given block on the stack. If it is possible to find the
+;;; parent in a consistent way with any one of these adjacent blocks,
+;;; we do not need a static link. Otherwise, we set
;;; `block-stack-link' to the empty list and use a static link.
+;;; Static links are currently avoided in only two cases:
+
+;;; - The procedure is always invoked with a continuation which
+;;; does not have the procedure's parent as an ancestor.
+;;; The only way for this to be the case and for the procedure's block
+;;; to be a stack block is if the procedure's parent has (eventually)
+;;; tail recursed into the procedure, and thus the block adjacent
+;;; on the stack is the parent's frame. Note that this includes the
+;;; case where the continuation is always externally supplied (passed
+;;; in).
+
+;;; - The procedure is always invoked with a particular continuation
+;;; which has the procedure's parent as an ancestor. The parent frame
+;;; can then be found from the continuation's frame. The adjacent
+;;; block is the continuation's block.
-;;; For dynamic links, we compute the popping limit of a procedure's
-;;; continuation variable, which is the farthest ancestor of the
-;;; procedure's block that is to be popped when invoking the
-;;; continuation. If we cannot compute the limit statically (value is
-;;; #F), we must use a dynamic link.
+;;; Remarks:
+
+;;; This analysis can be improved in the following way: Multiple
+;;; continuations as in the second case above are fine as long as the
+;;; parent can be obtained from all of them by the same access path.
+
+;;; If the procedure is invoked with a particular continuation which
+;;; does not have the procedure's parent as an ancestor, we are in the
+;;; presence of the first case above, namely, the parent block is
+;;; adjacent on the stack.
+
+;;; Dynamic links:
+
+;;; We compute the popping limit of a procedure's continuation
+;;; variable, which is the farthest ancestor of the procedure's block
+;;; that is to be popped when invoking the continuation. If we cannot
+;;; compute the limit statically (value is #F), we must use a dynamic
+;;; link.
;;; This code takes advantage of the fact that the continuation
;;; variable is not referenced in blocks other than the procedure's
-;;; block. This may change if call/cc is handled specially.
+;;; block. This may change if call-with-current-continuation is
+;;; handled specially.
+\f
+(package (continuation-analysis)
(define-export (continuation-analysis blocks)
(for-each (lambda (block)
lvalue
(analyze-continuation block lvalue))))))
blocks))
-\f
-(define (analyze-continuation block lvalue)
- (if (stack-parent? block)
- (let ((parent (block-parent block))
- (external (stack-block/external-ancestor block))
- (blocks (map continuation/block (lvalue-values lvalue))))
- (let ((closing-blocks (map->eq-set block-parent blocks))
- (closed-under-parent?
- (lambda (join-block)
- (or (eq? join-block block)
- (eq? join-block parent)))))
- (let ((join-blocks
- (continuation-join-blocks block
- lvalue
- external
- closing-blocks)))
- (set-block-stack-link!
- block
- (if (null? (lvalue-initial-values lvalue))
- ;; In this case, the procedure is always invoked
- ;; as a reduction. Use a static link unless one of
- ;; the places we reduce from is invoked with a
- ;; subproblem that is closed under the parent.
- (and (not (there-exists? join-blocks closed-under-parent?))
- parent)
- #|(assert
- (implies (not (null? (lvalue-initial-values lvalue)))
- (and (not (null? blocks))
- (not (null? closing-blocks))
- (not (null? join-blocks))))
- (implies (null? (cdr join-blocks))
- (and (null? (cdr blocks))
- (null? (cdr closing-blocks)))))|#
- (and (null? (cdr join-blocks))
- (closed-under-parent? (car join-blocks))
- ;; The procedure is always invoked as a
- ;; subproblem, and there is only a single
- ;; continuation. We could do better, but it's
- ;; not simple -- see the notes.
- (car blocks))))
- (let ((popping-limits
- (map->eq-set
- (lambda (join)
- (cond ((not join) external)
- ((eq? join block) block)
- (else
- (block-farthest-uncommon-ancestor block join))))
- join-blocks)))
- (and (not (null? popping-limits))
- (null? (cdr popping-limits))
- (car popping-limits))))))
- block))
-\f
+
(define (continuation-join-blocks block lvalue external closing-blocks)
(let ((ancestry (memq external (block-ancestry block '()))))
(let ((join-blocks
(if (lvalue-passed-in? lvalue)
(eq-set-adjoin false join-blocks)
join-blocks))))
+\f
+(define (analyze-continuation block lvalue)
+ (if (not (stack-parent? block))
+ block
+ (let ((parent (block-parent block))
+ (blocks (map continuation/block (lvalue-values lvalue))))
+ (set-block-stack-link!
+ block
+ (cond ((not (there-exists? blocks
+ (lambda (cont-block)
+ (block-ancestor-or-self? cont-block
+ parent))))
+ ;; Must have tail recursed through the parent.
+ parent)
+ ((and (not (null? blocks))
+ (null? (cdr blocks))
+ (not (lvalue-passed-in? lvalue)))
+ ;; Note that the there-exists? clause above
+ ;; implies (block-ancestor-or-self? (car blocks) parent)
+ ;; and therefore the parent can be found from the
+ ;; continuation.
+ (car blocks))
+ (else false)))
+ (let* ((external (stack-block/external-ancestor block))
+ (closing-blocks (map->eq-set block-parent blocks))
+ (join-blocks
+ (continuation-join-blocks block
+ lvalue
+ external
+ closing-blocks))
+ (popping-limits
+ (map->eq-set
+ (lambda (join)
+ (cond ((not join) external)
+ ((eq? join block) block)
+ (else
+ (block-farthest-uncommon-ancestor block join))))
+ join-blocks)))
+ (and (not (null? popping-limits))
+ (null? (cdr popping-limits))
+ (car popping-limits))))))
-)
\ No newline at end of file
+) ;; End of package
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.5 1988/02/17 19:10:57 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.6 1988/02/19 20:55:22 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(make-environment
(define :name "Liar (Bobcat 68020)")
(define :version 4)
- (define :modification 5)
+ (define :modification 6)
(define :files)
(define :rcs-header
- "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.5 1988/02/17 19:10:57 jinx Exp $")
+ "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.6 1988/02/19 20:55:22 jinx Exp $")
(define :files-lists
(list
(load-system! compiler-system))
-(for-each (lambda (name)
- (local-assignment system-global-environment name
+;; This does not use system-global-environment so that multiple
+;; versions of the compiler can coexist in different environments.
+;; This file must therefore be loaded into system-global-environment
+;; when the names below must be exported everywhere.
+
+(let ((top-level-env (the-environment)))
+ (for-each (lambda (name)
+ (local-assignment top-level-env name
(lexical-reference compiler-package name)))
- '(COMPILE-BIN-FILE COMPILE-PROCEDURE COMPILER:RESET!
- COMPILER:WRITE-LAP-FILE))
\ No newline at end of file
+ '(CF
+ COMPILE-BIN-FILE
+ COMPILE-PROCEDURE
+ COMPILER:RESET!
+ COMPILER:WRITE-LAP-FILE)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.2 1987/12/31 08:51:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.3 1988/02/19 20:57:55 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(ASSIGN (REGISTER 12) (OFFSET-ADDRESS (REGISTER 15) (? offset)))
(LAP (LEA (@AO 7 ,(* 4 offset)) (A 4))))
+(define-rule statement
+ (ASSIGN (REGISTER 12) (OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
+ (QUALIFIER (pseudo-register? source))
+ (LAP (LEA ,(indirect-reference! source offset) (A 4))))
+
;;; The following rule always occurs immediately after an instruction
;;; of the form
;;;
,temporary)
(MOV L ,temporary (@A+ 5))
(MOV B (& ,(ucode-type compiled-expression)) (@AO 5 -4)))))
+
+;; This pops the top of stack into the heap
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (POST-INCREMENT (REGISTER 15) 1))
+ (LAP (MOV L (@A+ 7) (@A+ 5))))
\f
;;;; Pushes
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.3 1988/02/17 19:11:22 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.4 1988/02/19 20:58:21 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(if (= how-far 1)
(LAP (MOV L (@AO 7 4) (@AO 7 8))
(MOV L (@A+ 7) (@A 7)))
- (let ((i (lambda (dis)
+ (let ((i (lambda ()
(INST (MOV L (@A+ 7)
- ,(offset-reference a7 dis))))))
- (LAP ,(i (-1+ how-far))
- ,(i (-1+ how-far))
+ ,(offset-reference a7 (-1+ how-far)))))))
+ (LAP ,(i)
+ ,(i)
,@(increment-anl 7 (- how-far 2))))))
(else
(generate/move-frame-up frame-size (offset-reference a7 offset))))))
projects / mit-scheme.git / commitdiff