#| -*-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
(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))))
#| -*-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
(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)
(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
+ |#
+ ))
+\f
+;;;; 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 &-)
#| -*-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
(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
#| -*-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
(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)
(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))))))
+\f
+(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
#| -*-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
(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)))
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!))
(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!)
(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)
(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
#| -*-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
((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
projects / mit-scheme.git / commitdiff