From f8c8039ac1ec47d2c3e9dfb3b18463f96d1f1b38 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 18 Aug 1988 01:37:23 +0000 Subject: [PATCH] Improve code generated for inputs like the following: (if (if (and (object-type? (ucode-type fixnum) r) (object-type? (ucode-type fixnum) l)) (fix:> r l) (> r l)) ...) Previously, the code generated for the call to `fix:>' was deficient in that it pushed a continuation, performed the inline coded comparison, then did a pop-return. In fact, since the continuation is known at that point, and is not being passed anywhere, there's no reason to push anything on the stack. These changes implement this. --- v7/src/compiler/base/contin.scm | 7 ++++-- v7/src/compiler/base/ctypes.scm | 17 ++++++++----- v7/src/compiler/fggen/fggen.scm | 35 +++++++++++++++------------ v7/src/compiler/fgopt/conect.scm | 7 +++--- v7/src/compiler/fgopt/offset.scm | 6 ++++- v7/src/compiler/fgopt/operan.scm | 35 ++++++++++++++++----------- v7/src/compiler/rtlgen/fndblk.scm | 4 ++-- v7/src/compiler/rtlgen/opncod.scm | 21 ++++++++++++---- v7/src/compiler/rtlgen/rgretn.scm | 40 ++++++++++++++++++------------- v7/src/compiler/rtlgen/rgstmt.scm | 5 ++-- v7/src/compiler/rtlgen/rtlgen.scm | 39 ++++++++++++++++-------------- 11 files changed, 130 insertions(+), 86 deletions(-) diff --git a/v7/src/compiler/base/contin.scm b/v7/src/compiler/base/contin.scm index 48fb75faf..f9b65521b 100644 --- a/v7/src/compiler/base/contin.scm +++ b/v7/src/compiler/base/contin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.3 1988/06/14 08:31:35 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.4 1988/08/18 01:34:39 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -73,7 +73,7 @@ MIT in each case. |# (define-integrable continuation/label procedure-label) (define-integrable continuation/returns procedure-applications) (define-integrable set-continuation/returns! set-procedure-applications!) -(define-integrable continuation/always-known-operator? +(define-integrable continuation/ever-known-operator? procedure-always-known-operator?) (define-integrable continuation/offset procedure-closure-offset) (define-integrable set-continuation/offset! set-procedure-closure-offset!) @@ -86,6 +86,9 @@ MIT in each case. |# (set-procedure-register! continuation register) register))) +(define-integrable (continuation/always-known-operator? continuation) + (eq? (continuation/ever-known-operator? continuation) 'ALWAYS)) + (define-integrable (continuation/parameter continuation) (car (procedure-original-required continuation))) diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index 6f6af520a..0dd52bb98 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.4 1988/07/16 20:54:39 hal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.5 1988/08/18 01:34:48 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -47,14 +47,16 @@ MIT in each case. |# (operators ;used in simulate-application arguments) ;used in outer-analysis operand-values ;set by outer-analysis, used by identify-closure-limits + continuation-push ) (define *applications*) -(define (make-application type block operator operands) +(define (make-application type block operator operands continuation-push) (let ((application (make-snode application-tag - type block operator operands false '() '()))) + type block operator operands false '() '() + continuation-push))) (set! *applications* (cons application *applications*)) (add-block-application! block application) (if (rvalue/reference? operator) @@ -88,13 +90,15 @@ MIT in each case. |# (set! *parallels* (cons parallel *parallels*)) (snode->scfg parallel))) -(define (make-combination block continuation operator operands) +(define (make-combination block continuation operator operands + continuation-push) (let ((application (make-application 'COMBINATION block (subproblem-rvalue operator) (cons continuation - (map subproblem-rvalue operands))))) + (map subproblem-rvalue operands)) + continuation-push))) (scfg*scfg->scfg! (make-parallel (cfg-entry-node application) (cons operator operands)) application))) @@ -109,6 +113,7 @@ MIT in each case. |# (define-integrable combination/frame-size application-operand-values) (define-integrable set-combination/frame-size! set-application-operand-values!) (define-integrable combination/inline? combination/inliner) +(define-integrable combination/continuation-push application-continuation-push) (define-integrable (combination/continuation combination) (car (application-operands combination))) @@ -133,7 +138,7 @@ MIT in each case. |# (set-application-operands! combination (list rvalue)))) (define-integrable (make-return block continuation rvalue) - (make-application 'RETURN block continuation (list rvalue))) + (make-application 'RETURN block continuation (list rvalue) false)) (define-integrable (application/return? application) (eq? (application-type application) 'RETURN)) diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index bbf71baff..2fff5b847 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.8 1988/08/11 20:13:27 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.9 1988/08/18 01:35:15 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -158,9 +158,11 @@ MIT in each case. |# generator) (if (virtual-continuation? continuation) (let ((continuation (virtual-continuation/reify! continuation))) - (scfg*value->value! (make-push block continuation) - (generator continuation))) - (generator continuation))) + (let ((push (make-push block continuation))) + (scfg*value->value! push + (generator (cfg-entry-node push) + continuation)))) + (generator false continuation))) (define (make-subproblem/canonical prefix continuation) (make-subproblem prefix @@ -464,7 +466,8 @@ MIT in each case. |# (with-reified-continuation block continuation scfg*subproblem->subproblem! - (lambda (continuation) + (lambda (push continuation) + push ;ignore (finish continuation (lambda (predicate consequent alternative) (make-subproblem/canonical @@ -478,7 +481,7 @@ MIT in each case. |# (scode/combination-components expression (lambda (operator operands) (let ((make-combination - (lambda (continuation) + (lambda (push continuation) (make-combination block (continuation-reference block continuation) @@ -487,18 +490,19 @@ MIT in each case. |# (generate/subproblem/value block continuation expression)) - operands))))) + operands) + push)))) ((continuation/case continuation - (lambda () (make-combination continuation)) + (lambda () (make-combination false continuation)) (lambda () (if (variable? continuation) (make-combination continuation) (with-reified-continuation block continuation scfg*scfg->scfg! - (lambda (continuation) + (lambda (push continuation) (make-scfg - (cfg-entry-node (make-combination continuation)) + (cfg-entry-node (make-combination push continuation)) (continuation/next-hooks continuation)))))) (lambda () (if (eq? not operator) @@ -506,19 +510,20 @@ MIT in each case. |# (generate/expression block continuation (car operands))) (with-reified-continuation block continuation scfg*pcfg->pcfg! - (lambda (continuation) + (lambda (push continuation) (scfg*pcfg->pcfg! (make-scfg - (cfg-entry-node (make-combination continuation)) + (cfg-entry-node (make-combination push continuation)) (continuation/next-hooks continuation)) (make-true-test (continuation/rvalue continuation))))))) (lambda () (with-reified-continuation block continuation scfg*subproblem->subproblem! - (lambda (continuation) - (make-subproblem/canonical (make-combination continuation) - continuation)))))))))) + (lambda (push continuation) + (make-subproblem/canonical + (make-combination push continuation) + continuation)))))))))) (define (generate/operator block continuation operator) (wrapper/subproblem/value block continuation diff --git a/v7/src/compiler/fgopt/conect.scm b/v7/src/compiler/fgopt/conect.scm index 084cc8184..d3622853d 100644 --- a/v7/src/compiler/fgopt/conect.scm +++ b/v7/src/compiler/fgopt/conect.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/conect.scm,v 4.1 1987/12/30 06:47:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/conect.scm,v 4.2 1988/08/18 01:35:41 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -48,7 +48,7 @@ MIT in each case. |# (define (procedure-direct-linked? procedure) (if (procedure-continuation? procedure) - (continuation/always-known-operator? procedure) + (continuation/ever-known-operator? procedure) (procedure-inline-code? procedure))) (define (walk-node node color) @@ -92,8 +92,7 @@ MIT in each case. |# (define (walk-continuation continuation color) (let ((rvalue (rvalue-known-value continuation))) - (if (and rvalue - (continuation/always-known-operator? rvalue)) + (if rvalue (walk-node (continuation/entry-node rvalue) color)))) ) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/offset.scm b/v7/src/compiler/fgopt/offset.scm index b9f0712be..9611fbebf 100644 --- a/v7/src/compiler/fgopt/offset.scm +++ b/v7/src/compiler/fgopt/offset.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.3 1988/06/14 08:35:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.4 1988/08/18 01:36:00 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -98,6 +98,10 @@ MIT in each case. |# (enumeration-case continuation-type (virtual-continuation/type operator) ((EFFECT) + (if (rvalue/continuation? operand) + (begin + (set-continuation/offset! operand offset) + (enqueue-procedure! operand))) offset) ((REGISTER VALUE) (walk-rvalue operand) diff --git a/v7/src/compiler/fgopt/operan.scm b/v7/src/compiler/fgopt/operan.scm index 7f4583482..e8626273f 100644 --- a/v7/src/compiler/fgopt/operan.scm +++ b/v7/src/compiler/fgopt/operan.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.2 1987/12/30 06:44:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.3 1988/08/18 01:36:20 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -80,19 +80,26 @@ MIT in each case. |# (define (analyze/continuation continuation) (and (not (continuation/passed-out? continuation)) - (let ((returns (continuation/returns continuation)) - (combinations (continuation/combinations continuation))) - (and (or (not (null? returns)) - (not (null? combinations))) - (for-all? returns - (lambda (return) - (eq? (rvalue-known-value (return/operator return)) - continuation))) - (for-all? combinations - (lambda (combination) - (eq? (rvalue-known-value - (combination/continuation combination)) - continuation))))))) + (3-logic/and + (for-some? (continuation/returns continuation) + (lambda (return) + (eq? (rvalue-known-value (return/operator return)) + continuation))) + (for-some? (continuation/combinations continuation) + (lambda (combination) + (eq? (rvalue-known-value (combination/continuation combination)) + continuation)))))) + +(define (for-some? items predicate) + (let loop ((items items) (default false)) + (cond ((null? items) 'ALWAYS) + ((predicate (car items)) (loop (cdr items) 'SOMETIMES)) + (else default)))) + +(define (3-logic/and x y) + (cond ((and (eq? x 'ALWAYS) (eq? y 'ALWAYS)) 'ALWAYS) + ((and (not x) (not y)) false) + (else 'SOMETIMES))) (define (analyze/procedure procedure) (and (not (procedure-passed-out? procedure)) diff --git a/v7/src/compiler/rtlgen/fndblk.scm b/v7/src/compiler/rtlgen/fndblk.scm index 2a2f5d574..e8959f0dc 100644 --- a/v7/src/compiler/rtlgen/fndblk.scm +++ b/v7/src/compiler/rtlgen/fndblk.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.7 1988/06/14 08:42:14 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.8 1988/08/18 01:36:46 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -40,7 +40,7 @@ MIT in each case. |# (if (variable/value-variable? variable) (if-compiler (let ((continuation (block-procedure start-block))) - (if (continuation/always-known-operator? continuation) + (if (continuation/ever-known-operator? continuation) (continuation/register continuation) register:value))) (find-variable-internal start-block variable offset diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 7aaee218a..f09798ee0 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.9 1988/06/14 09:37:08 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.10 1988/08/18 01:36:54 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -44,9 +44,21 @@ MIT in each case. |# (for-each (if compiler:open-code-primitives? (lambda (application) (if (eq? (application-type application) 'COMBINATION) - (set-combination/inliner! - application - (analyze-combination application)))) + (let ((inliner (analyze-combination application))) + (set-combination/inliner! application inliner) + ;; Don't push a return address on the stack + ;; if: (1) the combination is inline coded, + ;; (2) the continuation is known, and (3) the + ;; push is unique for this combination. + (let ((push + (combination/continuation-push application))) + (if (and inliner + push + (rvalue-known-value + (combination/continuation application))) + (set-virtual-continuation/type! + (virtual-return-operator push) + continuation-type/effect)))))) (lambda (application) (if (eq? (application-type application) 'COMBINATION) (set-combination/inliner! application false)))) @@ -79,6 +91,7 @@ MIT in each case. |# (let ((offset (node/offset combination))) (generate/return* (combination/block combination) (combination/continuation combination) + (combination/continuation-push combination) (let ((inliner (combination/inliner combination))) (let ((handler (inliner/handler inliner)) (generator (inliner/generator inliner)) diff --git a/v7/src/compiler/rtlgen/rgretn.scm b/v7/src/compiler/rtlgen/rgretn.scm index 6f70cccac..d2d7706b6 100644 --- a/v7/src/compiler/rtlgen/rgretn.scm +++ b/v7/src/compiler/rtlgen/rgretn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.3 1988/06/14 08:42:48 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.4 1988/08/18 01:37:05 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -39,11 +39,13 @@ MIT in each case. |# (define (generate/return return) (generate/return* (return/block return) (return/operator return) + false (trivial-return-operand (return/operand return)) (node/offset return))) (define (generate/trivial-return block operator operand offset) - (generate/return* block operator (trivial-return-operand operand) offset)) + (generate/return* block operator false (trivial-return-operand operand) + offset)) (define (trivial-return-operand operand) (make-return-operand @@ -66,13 +68,13 @@ MIT in each case. |# (package (generate/return*) -(define-export (generate/return* block operator operand offset) +(define-export (generate/return* block operator not-on-stack? operand offset) (let ((continuation (rvalue-known-value operator))) - (if (and continuation - (continuation/always-known-operator? continuation)) + (if continuation ((method-table-lookup simple-methods (continuation/type continuation)) block operator + not-on-stack? operand offset continuation) @@ -93,14 +95,14 @@ MIT in each case. |# (make-method-table continuation-types false)) (define-method-table-entry 'EFFECT simple-methods - (lambda (block operator operand offset continuation) + (lambda (block operator not-on-stack? operand offset continuation) (scfg-append! (effect-prefix operand offset) - (common-prefix block operator offset continuation) + (common-prefix block operator not-on-stack? offset continuation) (generate/node (continuation/entry-node continuation))))) (define-method-table-entries '(REGISTER VALUE) simple-methods - (lambda (block operator operand offset continuation) + (lambda (block operator not-on-stack? operand offset continuation) (scfg-append! (if (lvalue-integrated? (continuation/parameter continuation)) (effect-prefix operand offset) @@ -109,23 +111,25 @@ MIT in each case. |# (lambda (expression) (rtl:make-assignment (continuation/register continuation) expression)))) - (common-prefix block operator offset continuation) + (common-prefix block operator not-on-stack? offset continuation) (generate/node (continuation/entry-node continuation))))) (define-method-table-entry 'PUSH simple-methods - (lambda (block operator operand offset continuation) + (lambda (block operator not-on-stack? operand offset continuation) (scfg*scfg->scfg! - (let ((prefix (common-prefix block operator offset continuation))) + (let ((prefix + (common-prefix block operator not-on-stack? offset continuation))) (if (cfg-null? prefix) ((return-operand/value-generator operand) offset rtl:make-push) (use-temporary-register operand offset prefix rtl:make-push))) (generate/node (continuation/entry-node continuation))))) (define-method-table-entry 'PREDICATE simple-methods - (lambda (block operator operand offset continuation) + (lambda (block operator not-on-stack? operand offset continuation) (let ((node (continuation/entry-node continuation)) (value (return-operand/known-value operand)) - (prefix (common-prefix block operator offset continuation))) + (prefix + (common-prefix block operator not-on-stack? offset continuation))) (if value (scfg-append! (effect-prefix operand offset) @@ -180,9 +184,11 @@ MIT in each case. |# (define-integrable (effect-prefix operand offset) ((return-operand/effect-generator operand) offset)) -(define (common-prefix block operator offset continuation) - (scfg*scfg->scfg! - (return-operator/pop-frames block operator offset 0) - (generate/continuation-entry/ic-block continuation))) +(define (common-prefix block operator not-on-stack? offset continuation) + (if not-on-stack? + (return-operator/pop-frames block operator offset 0) + (scfg*scfg->scfg! + (return-operator/pop-frames block operator offset 1) + (generate/continuation-entry/pop-extra continuation)))) ) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index 15660190b..056cef226 100644 --- a/v7/src/compiler/rtlgen/rgstmt.scm +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.4 1988/06/14 08:43:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.5 1988/08/18 01:37:14 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -150,8 +150,7 @@ MIT in each case. |# (begin (enqueue-continuation! continuation) (scfg*scfg->scfg! - (if (and (stack-block? closing-block) - (stack-block/dynamic-link? closing-block)) + (if (block/dynamic-link? closing-block) (rtl:make-push-link) (make-null-cfg)) (rtl:make-push-return (continuation/label continuation)))))))) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index b326037bf..a8cb8c6b4 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.5 1988/06/14 08:43:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.6 1988/08/18 01:37:23 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -131,31 +131,34 @@ MIT in each case. |# (if (continuation/avoid-check? continuation) (rtl:make-continuation-entry label) (rtl:make-continuation-header label)) - (generate/continuation-entry/ic-block continuation) - (if (block/dynamic-link? - (continuation/closing-block continuation)) - (rtl:make-pop-link) - (make-null-cfg)) + (generate/continuation-entry/pop-extra continuation) (enumeration-case continuation-type (continuation/type continuation) ((PUSH) - (scfg*scfg->scfg! - (rtl:make-push (rtl:make-fetch register:value)) - (generate/node node))) + (rtl:make-push (rtl:make-fetch register:value))) ((REGISTER) - (scfg*scfg->scfg! - (rtl:make-assignment (continuation/register continuation) - (rtl:make-fetch register:value)) - (generate/node node))) + (rtl:make-assignment (continuation/register continuation) + (rtl:make-fetch register:value))) + ((VALUE) + (if (continuation/ever-known-operator? continuation) + (rtl:make-assignment (continuation/register continuation) + (rtl:make-fetch register:value)) + (make-null-cfg))) (else - (generate/node node)))))) + (make-null-cfg))) + (generate/node node)))) (lambda (rgraph entry-edge) (make-rtl-continuation rgraph label entry-edge))))) -(define (generate/continuation-entry/ic-block continuation) - (if (ic-block? (continuation/closing-block continuation)) - (rtl:make-pop register:environment) - (make-null-cfg))) +(define (generate/continuation-entry/pop-extra continuation) + (let ((block (continuation/closing-block continuation))) + (if (ic-block? block) + (rtl:make-pop register:environment) + (make-null-cfg)) + (if (and (not (continuation/always-known-operator? continuation)) + (block/dynamic-link? block)) + (rtl:make-pop-link) + (make-null-cfg))))) (define (generate/node node) (let ((memoization (cfg-node-get node memoization-tag))) -- 2.25.1