From 0282f1c0f98eadeb0762d23fe177537649e04d91 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Tue, 15 Nov 1988 16:37:29 +0000 Subject: [PATCH] Improve constant folding: - Mutable objects can now be known values of variables, although operations will not be open coded over them. - The outer analysis has been changed to have passed-out and passed-in counters rather than flags. In this way it is easy to recompute their values value after an operation has been constant folded, and decide whether further propagation can occur or not. - Non-primitive operations can now be constant folded. There is a new declaration: USUAL-DEFINITION which allows the variables to which it applies to be constant folded to their usual (global) definition. Examples of this are ATAN, GCD, etc. - Fix bug in base/utils.scm by which temporary label names were being interned. This would cause the compiler to run out of storage after many compilations. --- v7/src/compiler/base/lvalue.scm | 6 +- v7/src/compiler/base/utils.scm | 63 ++++++++--- v7/src/compiler/fggen/declar.scm | 5 +- v7/src/compiler/fgopt/folcon.scm | 102 +++++++++++++---- v7/src/compiler/fgopt/outer.scm | 103 ++++++++---------- .../compiler/machines/bobcat/make.scm-68040 | 4 +- 6 files changed, 183 insertions(+), 100 deletions(-) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index 0e664beba..1942934f4 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.7 1988/11/01 04:47:24 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.8 1988/11/15 16:33:41 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -238,7 +238,9 @@ MIT in each case. |# (lvalue/internal-source? lvalue))) (define-integrable (lvalue/external-source? lvalue) - (eq? 'SOURCE (lvalue-passed-in? lvalue))) + ;; (number? (lvalue-passed-in? lvalue)) + (and (lvalue-passed-in? lvalue) + (not (eq? (lvalue-passed-in? lvalue) 'INHERITED)))) (define-integrable (lvalue/internal-source? lvalue) (not (null? (lvalue-initial-values lvalue)))) diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index f86fea2f1..4750efca6 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.6 1988/11/08 21:25:58 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.7 1988/11/15 16:33:19 jinx Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1987, 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -68,7 +68,7 @@ MIT in each case. |# (define (generate-label #!optional prefix) (if (default-object? prefix) (set! prefix 'LABEL)) - (string->symbol + (string->uninterned-symbol (string-append (symbol->string (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA) @@ -255,24 +255,55 @@ MIT in each case. |# (scode/primitive-procedure? object) (eq? object compiled-error-procedure))) -(define (operator-constant-foldable? operator) +(define invariant-names + '( + ;; Predicates + OBJECT-TYPE? EQ? FALSE? NULL? PAIR? VECTOR? SYMBOL? STRING? + NUMBER? CHAR? PROMISE? BIT-STRING? CELL? CHAR-ASCII? + + ;; Numbers + COMPLEX? REAL? RATIONAL? INTEGER? EXACT? INEXACT? + ZERO? POSITIVE? NEGATIVE? ODD? EVEN? + = < > <= >= MAX MIN + + - * / 1+ -1+ ABS QUOTIENT REMAINDER MODULO INTEGER-DIVIDE + GCD LCM FLOOR CEILING TRUNCATE ROUND + EXP LOG EXPT SQRT SIN COS TAN ASIN ACOS ATAN + FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE? + FIX:= FIX:< FIX:> FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:* + FIX:DIVIDE FIX:GCD FIX:QUOTIENT FIX:REMAINDER + + ;; Random + OBJECT-TYPE NOT ASCII->CHAR CHAR->INTEGER CHAR-BITS CHAR-CODE + CHAR-DOWNCASE CHAR-UPCASE INTEGER->CHAR VECTOR-LENGTH MAKE-CHAR + PRIMITIVE-PROCEDURE-ARITY STRING-MAXIMUM-LENGTH + + ;; If we could guarantee no side effects + #| APPLY CONS LIST CONS* MAKE-STRING VECTOR MAKE-VECTOR LIST-COPY VECTOR-COPY + CAR CDR VECTOR-REF STRING-REF BIT-STRING-REF LENGTH LIST->VECTOR VECTOR->LIST + MAKE-BIT-STRING MAKE-CELL STRING->SYMBOL STRING-LENGTH + |# + )) + +;;;; Constant "Foldable" operators + +(define (constant-foldable-primitive? operator) (memq operator constant-foldable-primitives)) +(define (variable-usual-definition name) + (let ((place (assq name invariant-variables))) + (and place + (cdr place)))) + +(define invariant-variables + (map (lambda (name) + (cons name + (lexical-reference system-global-environment name))) + invariant-names)) + (define constant-foldable-primitives (append! (list-transform-positive - (map (lambda (name) - (lexical-reference system-global-environment name)) - '(OBJECT-TYPE OBJECT-TYPE? - EQ? NULL? PAIR? NUMBER? COMPLEX? REAL? RATIONAL? INTEGER? - ZERO? POSITIVE? NEGATIVE? ODD? EVEN? EXACT? INEXACT? - = < > <= >= MAX MIN - + - * / 1+ -1+ ABS QUOTIENT REMAINDER MODULO INTEGER-DIVIDE - GCD LCM FLOOR CEILING TRUNCATE ROUND - EXP LOG EXPT SQRT SIN COS TAN ASIN ACOS ATAN - FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE? - FIX:= FIX:< FIX:> FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:* - FIX:DIVIDE FIX:GCD FIX:QUOTIENT FIX:REMAINDER)) + (map cdr invariant-variables) (lexical-reference system-global-environment 'PRIMITIVE-PROCEDURE?)) (list (ucode-primitive &+) (ucode-primitive &-) diff --git a/v7/src/compiler/fggen/declar.scm b/v7/src/compiler/fggen/declar.scm index 839a2b09b..a3729e28c 100644 --- a/v7/src/compiler/fggen/declar.scm +++ b/v7/src/compiler/fggen/declar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/declar.scm,v 1.3 1988/11/02 21:54:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/declar.scm,v 1.4 1988/11/15 16:34:06 jinx Exp $ Copyright (c) 1987, 1988 Massachusetts Institute of Technology @@ -139,4 +139,5 @@ MIT in each case. |# (define-declaration 'UUO-LINK boolean-variable-property) (define-declaration 'CONSTANT boolean-variable-property) (define-declaration 'IGNORE-REFERENCE-TRAPS boolean-variable-property) -(define-declaration 'IGNORE-ASSIGNMENT-TRAPS boolean-variable-property) \ No newline at end of file +(define-declaration 'IGNORE-ASSIGNMENT-TRAPS boolean-variable-property) +(define-declaration 'USUAL-DEFINITION boolean-variable-property) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/folcon.scm b/v7/src/compiler/fgopt/folcon.scm index e86bb5487..1350d2c97 100644 --- a/v7/src/compiler/fgopt/folcon.scm +++ b/v7/src/compiler/fgopt/folcon.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/folcon.scm,v 4.3 1988/11/06 13:55:39 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/folcon.scm,v 4.4 1988/11/15 16:32:34 jinx Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987, 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -63,9 +63,7 @@ MIT in each case. |# (and (not (null? values)) (null? (cdr values)) (or (rvalue/procedure? (car values)) - (and (rvalue/constant? (car values)) - (object-immutable? - (constant-value (car values)))))))))))) + (rvalue/constant? (car values)))))))))) (for-each (lambda (lvalue) (lvalue-mark-set! lvalue 'KNOWABLE)) knowable-nodes) (transitive-closure false delete-if-known! knowable-nodes) @@ -100,25 +98,83 @@ MIT in each case. |# (let ((operator (combination/operator combination)) (continuation (combination/continuation combination)) (operands (combination/operands combination))) - (and (rvalue-known-constant? operator) - (let ((operator (rvalue-constant-value operator))) - (and (operator-constant-foldable? operator) - (primitive-arity-correct? operator (length operands)))) + (and (constant-foldable-operator? operator) ;; (rvalue-known? continuation) ;; (uni-continuation? (rvalue-known-value continuation)) - (for-all? operands rvalue-known-constant?) - (begin - (let ((constant - (make-constant - (apply (rvalue-constant-value operator) - (map rvalue-constant-value operands))))) - (combination/constant! combination constant) - (map (lambda (value) - (if (uni-continuation? value) - (lvalue-connect!:rvalue - (uni-continuation/parameter value) - constant))) - (rvalue-values continuation))) - true)))) + (for-all? operands + (lambda (val) + (and (rvalue-known-constant? val) + (object-immutable? (rvalue-constant-value val))))) + (let ((op (constant-foldable-operator-value operator))) + (and (or (arity-correct? op (length operands)) + (begin + (error "fold-combination: Wrong number of arguments" + op (length operands)) + false)) + (let ((constant + (make-constant + (apply op (map rvalue-constant-value operands))))) + (combination/constant! combination constant) + (for-each (lambda (value) + (if (uni-continuation? value) + (maybe-fold-lvalue! + (uni-continuation/parameter value) + constant))) + (rvalue-values continuation)) + true)))))) + +(define (maybe-fold-lvalue! lvalue constant) + (lvalue-connect!:rvalue lvalue constant) + (reset-lvalue-cache! lvalue) + (let ((val (lvalue-passed-in? lvalue))) + (if (or (false? val) (eq? val 'INHERITED)) ; (not (number? val)) + (error "maybe-fold-lvalue!: Folding a non source!" lvalue) + (let ((new (-1+ val))) + (cond ((not (zero? new)) + (set-lvalue-passed-in?! lvalue new)) + ((recompute-lvalue-passed-in! lvalue) + (for-each (lambda (lvalue) + ;; We don't recompute-lvalue-passed-in! recursively + ;; because the forward-link relationship is transitively + ;; closed. + (if (eq? (lvalue-passed-in? lvalue) 'INHERITED) + (recompute-lvalue-passed-in! lvalue))) + (lvalue-forward-links lvalue)))))))) + +;; This returns true if the lvalue went from passed-in to not +;; passed-in. It initializes the value to false because it may +;; be in its own backward-link list. + +(define (recompute-lvalue-passed-in! lvalue) + (set-lvalue-passed-in?! lvalue false) + (if (there-exists? (lvalue-backward-links lvalue) lvalue-passed-in?) + (begin + (set-lvalue-passed-in?! lvalue 'INHERITED) + ;; The assignment would return the right value, but this is clearer. + false) + true)) + +(define (constant-foldable-operator? rv) + (or (and (rvalue-known-constant? rv) + (let ((val (rvalue-constant-value rv))) + (and (primitive-procedure? val) + (constant-foldable-primitive? val)))) + (and (rvalue/reference? rv) + ;; (not (reference-known-value rv)) + (not (reference-to-known-location? rv)) + (let ((var (reference-lvalue rv))) + (and (memq 'USUAL-DEFINITION (variable-declarations var)) + (variable-usual-definition (variable-name var))))))) + +(define (constant-foldable-operator-value rv) + (if (rvalue/reference? rv) + (variable-usual-definition (variable-name (reference-lvalue rv))) + (rvalue-constant-value rv))) + +(define (arity-correct? proc n) + (let ((arity (procedure-arity proc))) + (and (>= n (car arity)) + (or (null? (cdr arity)) + (<= n (cdr arity)))))) ) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/outer.scm b/v7/src/compiler/fgopt/outer.scm index 8cf29746d..ce9683223 100644 --- a/v7/src/compiler/fgopt/outer.scm +++ b/v7/src/compiler/fgopt/outer.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/outer.scm,v 4.3 1987/12/30 06:44:51 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/outer.scm,v 4.4 1988/11/15 16:32:58 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -74,22 +74,9 @@ MIT in each case. |# (application-arguments-passed-out! application))) (define (check-application application) - (if (rvalue-passed-in? (application-operator application)) - (application-arguments-passed-out! application)) -#| - ;; This looks like it isn't necessary, but I seem to recall that it - ;; was needed to fix some bug. If so, then there is a serious - ;; problem, since we could "throw" into some operand other than - ;; the continuation. -- CPH. - (if (and (application/combination? application) - (there-exists? (combination/operands application) - rvalue-passed-in?)) - (for-each (lambda (value) - (if (uni-continuation? value) - (lvalue-passed-in! (uni-continuation/parameter value)))) - (rvalue-values (combination/continuation application)))) -|# - ) + (if (and (rvalue-passed-in? (application-operator application)) + (not (null? (application-arguments application)))) + (application-arguments-passed-out! application))) (define (application-arguments-passed-out! application) (let ((arguments (application-arguments application))) @@ -101,7 +88,11 @@ MIT in each case. |# rvalue)) (define-integrable (%rvalue-passed-out! rvalue) - (set-rvalue-%passed-out?! rvalue true)) + (set-rvalue-%passed-out?! rvalue + (let ((old (rvalue-%passed-out? rvalue))) + (if old + (1+ old) + 1)))) (define passed-out-methods (make-method-table rvalue-types %rvalue-passed-out!)) @@ -112,32 +103,28 @@ MIT in each case. |# (define-method-table-entry 'PROCEDURE passed-out-methods (lambda (procedure) - (if (not (rvalue-%passed-out? procedure)) - (begin - (%rvalue-passed-out! procedure) - ;; The rest parameter was marked in the initialization. - (for-each lvalue-passed-in! (procedure-required procedure)) - (for-each lvalue-passed-in! (procedure-optional procedure)))))) + (%rvalue-passed-out! procedure) + ;; The rest parameter was marked in the initialization. + (for-each lvalue-passed-in! (procedure-required procedure)) + (for-each lvalue-passed-in! (procedure-optional procedure)))) (define (block-passed-out! block) - (if (not (rvalue-%passed-out? block)) - (begin - (%rvalue-passed-out! block) - (for-each (let ((procedure (block-procedure block))) - (if (and (rvalue/procedure? procedure) - (not (procedure-continuation? procedure))) - (let ((continuation - (procedure-continuation-lvalue procedure))) - (lambda (lvalue) - (if (not (eq? lvalue continuation)) - (lvalue-externally-visible! lvalue)))) - lvalue-externally-visible!)) - (block-bound-variables block)) - (let ((parent (block-parent block))) - (if parent - (block-passed-out! parent) - (for-each lvalue-externally-visible! - (block-free-variables block))))))) + (%rvalue-passed-out! block) + (for-each (let ((procedure (block-procedure block))) + (if (and (rvalue/procedure? procedure) + (not (procedure-continuation? procedure))) + (let ((continuation + (procedure-continuation-lvalue procedure))) + (lambda (lvalue) + (if (not (eq? lvalue continuation)) + (lvalue-externally-visible! lvalue)))) + lvalue-externally-visible!)) + (block-bound-variables block)) + (let ((parent (block-parent block))) + (if parent + (block-passed-out! parent) + (for-each lvalue-externally-visible! + (block-free-variables block))))) (define-method-table-entry 'BLOCK passed-out-methods block-passed-out!) @@ -149,14 +136,17 @@ MIT in each case. |# (lvalue-passed-out! lvalue)) (define (lvalue-passed-in! lvalue) - (if (lvalue-passed-in? lvalue) - (set-lvalue-passed-in?! lvalue 'SOURCE) - (begin - (%lvalue-passed-in! lvalue 'SOURCE) - (for-each (lambda (lvalue) - (if (not (lvalue-passed-in? lvalue)) - (%lvalue-passed-in! lvalue 'INHERITED))) - (lvalue-forward-links lvalue))))) + (let ((prev (lvalue-passed-in? lvalue))) + (cond ((false? prev) + (%lvalue-passed-in! lvalue 1) + (for-each (lambda (lvalue) + (if (not (lvalue-passed-in? lvalue)) + (%lvalue-passed-in! lvalue 'INHERITED))) + (lvalue-forward-links lvalue))) + ((not (eq? prev 'INHERITED)) ; (number? prev) + (set-lvalue-passed-in?! lvalue (1+ prev))) + (else + (set-lvalue-passed-in?! lvalue 1))))) (define (%lvalue-passed-in! lvalue value) (set-lvalue-passed-in?! lvalue value) @@ -166,12 +156,15 @@ MIT in each case. |# (lvalue-applications lvalue))) (define (lvalue-passed-out! lvalue) - (if (not (lvalue-passed-out? lvalue)) - (begin (%lvalue-passed-out! lvalue) - (for-each %lvalue-passed-out! (lvalue-backward-links lvalue)) - (for-each rvalue-passed-out! (lvalue-values lvalue))))) + (%lvalue-passed-out! lvalue) + (for-each %lvalue-passed-out! (lvalue-backward-links lvalue)) + (for-each rvalue-passed-out! (lvalue-values lvalue))) (define-integrable (%lvalue-passed-out! lvalue) - (set-lvalue-passed-out?! lvalue true)) + (set-lvalue-passed-out?! lvalue + (let ((old (lvalue-passed-out? lvalue))) + (if old + (1+ old) + 1)))) ) \ 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 7c6409232..ea1b08e3d 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.29 1988/11/08 11:17:29 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.30 1988/11/15 16:37:29 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -41,4 +41,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar" 4 29 '())) \ No newline at end of file +(add-system! (make-system "Liar" 4 30 '())) \ No newline at end of file -- 2.25.1