From b04a80ed3ba061508721bf29cc4ac31562737acd Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Fri, 19 Feb 1988 20:58:57 +0000 Subject: [PATCH] Fix a bug in the continuation analyzer which was causing the compiler 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. --- v7/src/compiler/back/bittop.scm | 21 +-- v7/src/compiler/base/toplev.scm | 137 +++++++++++---- v7/src/compiler/fgopt/contan.scm | 159 ++++++++++-------- .../compiler/machines/bobcat/make.scm-68040 | 23 ++- v7/src/compiler/machines/bobcat/rules1.scm | 13 +- v7/src/compiler/machines/bobcat/rules3.scm | 10 +- 6 files changed, 232 insertions(+), 131 deletions(-) diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm index ff7ece1bc..1c52893f7 100644 --- a/v7/src/compiler/back/bittop.scm +++ b/v7/src/compiler/back/bittop.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -68,27 +68,20 @@ MIT in each case. |# (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? @@ -96,7 +89,7 @@ MIT in each case. |# (clear-symbol-table!) (initialize-symbol-table!) (loop (phase-1 directives) (1+ count))) - (tension-message count)))))) + count))))) (loop vars 0)) ;;;; Output block generation diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 55e2acba6..9ee968d36 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -130,6 +130,26 @@ MIT in each case. |# compiler:real-time) value))) +;;;; 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) @@ -140,6 +160,43 @@ MIT in each case. |# (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)))) + +;;; 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))))) + (define (compiler-pathnames input-string output-string default transform) (let ((kernel (lambda (input-string) @@ -160,8 +217,7 @@ MIT in each case. |# (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)))) @@ -236,7 +292,10 @@ MIT in each case. |# (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) @@ -244,7 +303,7 @@ MIT in each case. |# (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 @@ -266,7 +325,7 @@ MIT in each case. |# (SET! ,name))) (define (phase/fg-generation) - (compiler-phase 'FG-GENERATION + (compiler-phase "Generating the Flow Graph" (lambda () (set! *current-label-number* 0) (set! *constants* '()) @@ -289,7 +348,7 @@ MIT in each case. |# (set! *expressions*)))) (define (phase/fg-optimization) - (compiler-superphase 'FG-OPTIMIZATION + (compiler-superphase "Optimizing the Flow Graph" (lambda () (phase/simulate-application) (phase/outer-analysis) @@ -306,14 +365,14 @@ MIT in each case. |# (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*)))) (define (phase/outer-analysis) - (compiler-subphase 'OUTER-ANALYSIS + (compiler-subphase "Outer Analysis" (lambda () ((access outer-analysis fg-optimizer-package) *root-expression* @@ -321,27 +380,27 @@ MIT in each case. |# *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* @@ -349,50 +408,50 @@ MIT in each case. |# *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*)))) (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*) @@ -405,7 +464,7 @@ MIT in each case. |# (set! *root-block*)))))) (define (phase/rtl-generation) - (compiler-phase 'RTL-GENERATION + (compiler-phase "Generating RTL" (lambda () (set! *rtl-procedures* '()) (set! *rtl-continuations* '()) @@ -431,7 +490,7 @@ MIT in each case. |# 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)) @@ -440,7 +499,7 @@ MIT in each case. |# (write-string " mean"))))) (define (phase/rtl-optimization) - (compiler-superphase 'RTL-OPTIMIZATION + (compiler-superphase "Optimizing RTL" (lambda () (if compiler:cse? (phase/common-subexpression-elimination)) @@ -451,28 +510,28 @@ MIT in each case. |# (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*)))) (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*)))) @@ -488,7 +547,7 @@ MIT in each case. |# *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) @@ -505,7 +564,7 @@ MIT in each case. |# (set! *rtl-continuations*)))))) (define (phase/bit-linearization) - (compiler-phase 'BIT-LINEARIZATION + (compiler-phase "Linearizing BITs" (lambda () (set! compiler:bits (LAP ,@(lap:make-entry-point compiler:entry-label @@ -516,7 +575,7 @@ MIT in each case. |# (set! *rtl-graphs*)))))))) (define (phase/assemble) - (compiler-phase 'ASSEMBLE + (compiler-phase "Assembling" (lambda () (if compiler:preserve-data-structures? ((access assemble bit-package) @@ -528,13 +587,19 @@ MIT in each case. |# (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 @@ -546,7 +611,7 @@ MIT in each case. |# (pathname->string pathname))))) (define (phase/link) - (compiler-phase 'LINK + (compiler-phase "Linking" (lambda () ;; This has sections locked against GC since the code may not be ;; purified. diff --git a/v7/src/compiler/fgopt/contan.scm b/v7/src/compiler/fgopt/contan.scm index 4396252f7..7b0ce6b54 100644 --- a/v7/src/compiler/fgopt/contan.scm +++ b/v7/src/compiler/fgopt/contan.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -36,25 +36,59 @@ MIT in each case. |# (declare (usual-integrations)) -(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. + +(package (continuation-analysis) (define-export (continuation-analysis blocks) (for-each (lambda (block) @@ -71,59 +105,7 @@ MIT in each case. |# lvalue (analyze-continuation block lvalue)))))) blocks)) - -(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)) - + (define (continuation-join-blocks block lvalue external closing-blocks) (let ((ancestry (memq external (block-ancestry block '())))) (let ((join-blocks @@ -144,5 +126,46 @@ MIT in each case. |# (if (lvalue-passed-in? lvalue) (eq-set-adjoin false join-blocks) join-blocks)))) + +(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 diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index b03984606..eab1b8d6c 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-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 @@ -44,11 +44,11 @@ MIT in each case. |# (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 @@ -204,8 +204,17 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm index 166dc5cf1..352033eed 100644 --- a/v7/src/compiler/machines/bobcat/rules1.scm +++ b/v7/src/compiler/machines/bobcat/rules1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -59,6 +59,11 @@ MIT in each case. |# (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 ;;; @@ -243,6 +248,12 @@ MIT in each case. |# ,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)))) ;;;; Pushes diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 50bc13886..b94267be8 100644 --- a/v7/src/compiler/machines/bobcat/rules3.scm +++ b/v7/src/compiler/machines/bobcat/rules3.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -162,11 +162,11 @@ MIT in each case. |# (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)))))) -- 2.25.1