#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 4.1 1988/06/13 12:29:04 cph Rel $
+$Id: cgen.scm,v 4.2 1993/08/03 03:09:44 gjr Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; SCode Optimizer: Generate SCode from Expression
+;;; package: (scode-optimizer cgen)
(declare (usual-integrations)
(automagic-integrations)
(eta-substitution)
(integrate-external "object"))
\f
+(define *sf-associate*
+ (lambda (new old)
+ old new
+ false))
+
+(define (cgen/output old new)
+ (*sf-associate* new (and old (object/scode old)))
+ new)
+
(define (cgen/external quotation)
(fluid-let ((flush-declarations? true))
- (cgen/top-level quotation)))
+ (cgen/output quotation
+ (cgen/top-level quotation))))
(define (cgen/external-with-declarations expression)
(fluid-let ((flush-declarations? false))
(define dispatch-vector
(expression/make-dispatch-vector))
-(define define-method/cgen
+(define %define-method/cgen
(expression/make-method-definer dispatch-vector))
+(define-integrable (define-method/cgen type handler)
+ (%define-method/cgen type
+ (lambda (interns expression)
+ (cgen/output expression (handler interns expression)))))
+
(define (cgen/variable interns variable)
(cdr (or (assq variable (cdr interns))
(let ((association
#| -*-Scheme-*-
-$Id: copy.scm,v 4.2 1993/01/02 07:33:34 cph Exp $
+$Id: copy.scm,v 4.3 1993/08/03 03:09:45 gjr Exp $
-Copyright (c) 1988, 1993 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; SCode Optimizer: Copy Expression
+;;; package: (scode-optimizer copy)
(declare (usual-integrations)
(integrate-external "object"))
(fluid-let ((root-block false))
(let ((block (quotation/block quotation))
(environment (environment/make)))
- (quotation/make block
+ (quotation/make (quotation/scode quotation)
+ block
(copy/expression block
environment
(quotation/expression quotation))))))
\f
(define-method/copy 'ACCESS
(lambda (block environment expression)
- (access/make (copy/expression block
+ (access/make (access/scode expression)
+ (copy/expression block
environment
(access/environment expression))
(access/name expression))))
(define-method/copy 'ASSIGNMENT
(lambda (block environment expression)
(assignment/make
+ (assignment/scode expression)
block
(copy/variable block environment (assignment/variable expression))
(copy/expression block environment (assignment/value expression)))))
(define-method/copy 'COMBINATION
(lambda (block environment expression)
(combination/make
+ (combination/scode expression)
(copy/expression block environment (combination/operator expression))
(copy/expressions block environment (combination/operands expression)))))
(define-method/copy 'CONDITIONAL
(lambda (block environment expression)
(conditional/make
+ (conditional/scode expression)
(copy/expression block environment (conditional/predicate expression))
(copy/expression block environment (conditional/consequent expression))
(copy/expression block
(define-method/copy 'DECLARATION
(lambda (block environment expression)
(declaration/make
+ (declaration/scode expression)
(copy/declarations block
environment
(declaration/declarations expression))
(define-method/copy 'DELAY
(lambda (block environment expression)
(delay/make
+ (delay/scode expression)
(copy/expression block environment (delay/expression expression)))))
(define-method/copy 'DISJUNCTION
(lambda (block environment expression)
(disjunction/make
+ (disjunction/scode expression)
(copy/expression block environment (disjunction/predicate expression))
(copy/expression block
environment
(define-method/copy 'IN-PACKAGE
(lambda (block environment expression)
(in-package/make
+ (in-package/scode expression)
(copy/expression block environment (in-package/environment expression))
(copy/quotation (in-package/quotation expression)))))
\f
(copy/block block environment (procedure/block procedure)))
(lambda (block environment)
(let ((rename (make-renamer environment)))
- (procedure/make block
+ (procedure/make (procedure/scode procedure)
+ block
(procedure/name procedure)
(map rename (procedure/required procedure))
(map rename (procedure/optional procedure))
(copy/block block environment (open-block/block expression)))
(lambda (block environment)
(open-block/make
+ (open-block/scode expression)
block
(map (make-renamer environment) (open-block/variables expression))
(copy/expressions block environment (open-block/values expression))
(define-method/copy 'REFERENCE
(lambda (block environment expression)
- (reference/make block
+ (reference/make (reference/scode expression)
+ block
(copy/variable block environment
(reference/variable expression)))))
(define-method/copy 'SEQUENCE
(lambda (block environment expression)
(sequence/make
+ (sequence/scode expression)
(copy/expressions block environment (sequence/actions expression)))))
(define-method/copy 'THE-ENVIRONMENT
#| -*-Scheme-*-
-$Id: object.scm,v 4.5 1993/01/02 07:33:36 cph Exp $
+$Id: object.scm,v 4.6 1993/08/03 03:09:47 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
(let-syntax
((define-simple-type
- (macro (name slots)
+ (macro (name slots #!optional scode?)
`(DEFINE-STRUCTURE (,name (TYPE VECTOR)
(NAMED ,(symbol-append name '/ENUMERAND))
(CONC-NAME ,(symbol-append name '/))
(CONSTRUCTOR ,(symbol-append name '/MAKE)))
+ ,@(if (or (default-object? scode?) scode?)
+ `((scode false read-only true))
+ `())
,@slots))))
- (define-simple-type variable (block name flags))
+ (define-simple-type variable (block name flags) #F)
(define-simple-type access (environment name))
(define-simple-type assignment (block variable value))
(define-simple-type combination (operator operands))
(define-simple-type sequence (actions))
(define-simple-type the-environment (block)))
+;; Abstraction violations
+
(define-integrable (object/enumerand object)
(vector-ref object 0))
(define-integrable (set-object/enumerand! object enumerand)
(vector-set! object 0 enumerand))
+
+(define-integrable (object/scode object)
+ (vector-ref object 1))
+
+(define (with-new-scode scode object)
+ (let ((new (vector-copy object)))
+ (vector-set! new 1 scode)
+ new))
\f
;;;; Miscellany
(enumeration/name->index enumeration/expression name)))
(define-integrable (global-ref/make name)
- (access/make (constant/make system-global-environment) name))
+ (access/make false
+ (constant/make false system-global-environment)
+ name))
(define (global-ref? object)
(and (access? object)
(access/name object)))
(define-integrable (constant->integration-info constant)
- (make-integration-info (constant/make constant)))
+ (make-integration-info (constant/make false constant)))
(define-integrable (integration-info? object)
(and (pair? object)
#| -*-Scheme-*-
-$Id: sf.pkg,v 4.8 1993/01/02 07:33:37 cph Exp $
+$Id: sf.pkg,v 4.9 1993/08/03 03:09:48 gjr Exp $
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(export (scode-optimizer)
integrate/top-level
integrate/get-top-level-block
+ reassign
variable/final-value)
(import (runtime parser)
lambda-optional-tag))
(files "cgen")
(parent (scode-optimizer))
(export (scode-optimizer)
+ *sf-associate*
cgen/external)
(export (scode-optimizer expansion)
cgen/external-with-declarations))
#| -*-Scheme-*-
-$Id: subst.scm,v 4.9 1993/01/02 07:33:37 cph Exp $
+$Id: subst.scm,v 4.10 1993/08/03 03:09:49 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(define *current-block-names*)
(define (integrate/top-level block expression)
+ (integrate/top-level* (object/scode expression) block expression))
+
+(define (integrate/top-level* scode block expression)
(fluid-let ((*top-level-block* block)
(*current-block-names* '()))
(call-with-values
environment
expression))))))))
(lambda (operations environment expression)
- (values operations environment (quotation/make block expression))))))
+ (values operations environment
+ (quotation/make scode
+ block
+ expression))))))
(define (integrate/expressions operations environment expressions)
(map (lambda (expression)
;; The value of an assignment is the old value
;; of the variable, hence, it is refernced.
(variable/reference! variable)
- (assignment/make (assignment/block assignment)
+ (assignment/make (assignment/scode assignment)
+ (assignment/block assignment)
variable
(integrate/expression operations
environment
expression))
(try-safe-integration
(lambda ()
- (integrate/name-if-safe expression environment operations
+ (integrate/name-if-safe expression expression
+ environment operations
integration-success
integration-failure))))
(operations/lookup operations variable
(variable/reference! variable)
expression)
((INTEGRATE)
- (integrate/name expression info environment
- integration-success
- integration-failure))
+ (integrate/name expression expression info environment
+ integration-success integration-failure))
((INTEGRATE-SAFELY)
(try-safe-integration))
(else
(try-safe-integration)
(integration-failure))))))))
\f
-(define (integrate/name-if-safe reference environment operations
- if-win if-fail)
+(define (integrate/name-if-safe expr reference environment
+ operations if-win if-fail)
(let ((variable (reference/variable reference)))
(if (or (variable/side-effected variable)
(not (block/safe? (variable/block variable))))
(lambda (value)
(if (constant-value? value environment operations)
(if-win
- (copy/expression/intern (reference/block reference)
- value))
+ (reassign
+ expr
+ (copy/expression/intern (reference/block reference)
+ value)))
(if-fail)))))
(environment/lookup environment variable
(lambda (value)
(lambda () (if-fail))
(lambda () (if-fail)))))))
+(define (reassign expr object)
+ (if (and expr (object/scode expr))
+ ;; Abstraction violation
+ (with-new-scode (object/scode expr) object)
+ object))
+
(define (constant-value? value environment operations)
(let check ((value value) (top? true))
(or (constant? value)
;; not found variable
true)))))))))
\f
-(define (integrate/reference-operator operations environment operator operands)
+(define (integrate/reference-operator expression operations
+ environment operator operands)
(let ((variable (reference/variable operator)))
(letrec ((mark-integrated!
(lambda ()
(integration-failure
(lambda ()
(variable/reference! variable)
- (combination/optimizing-make operator operands)))
+ (combination/optimizing-make expression operator operands)))
(integration-success
(lambda (operator)
(mark-integrated!)
- (integrate/combination operations environment
+ (integrate/combination expression
+ operations environment
operator operands)))
(try-safe-integration
(lambda ()
- (integrate/name-if-safe operator environment operations
+ (integrate/name-if-safe expression operator
+ environment operations
integration-success
integration-failure))))
(operations/lookup operations variable
(case operation
((#F) (integration-failure))
((INTEGRATE INTEGRATE-OPERATOR)
- (integrate/name operator info environment
+ (integrate/name expression
+ operator info environment
integration-success
integration-failure))
((INTEGRATE-SAFELY)
(try-safe-integration))
((EXPAND)
- (info operands
+ (info expression
+ operands
(lambda (new-expression)
(mark-integrated!)
(integrate/expression operations environment
(values operations
environment
(if (open-block/optimized expression)
- (open-block/make block variables vals actions true)
+ (open-block/make
+ (and expression (object/scode expression))
+ block variables
+ vals actions true)
(open-block/optimizing-make
- block variables vals actions operations
- environment)))))))))))
+ expression block variables vals
+ actions operations environment)))))))))))
(define-method/integrate 'OPEN-BLOCK
(lambda (operations environment expression)
(list->set variable? eq? required)
(free/expression (combination/operator body)))))
(combination/operator body)
- (procedure/make block
+ (procedure/make (procedure/scode procedure)
+ block
(procedure/name procedure)
required
optional
(and (reference? this-operand)
(eq? (reference/variable this-operand) this-required)
(match-up? (cdr operands) (cdr required)))))))
-
\f
(define-method/integrate 'COMBINATION
(lambda (operations environment combination)
(integrate/combination
- operations
- environment
+ combination operations environment
(combination/operator combination)
(integrate/expressions operations
environment
(combination/operands combination)))))
-(define (integrate/combination operations environment operator operands)
+(define (integrate/combination expression operations environment
+ operator operands)
(cond ((reference? operator)
- (integrate/reference-operator operations
- environment
- operator
- operands))
+ (integrate/reference-operator expression operations environment
+ operator operands))
((and (access? operator)
(system-global-environment? (access/environment operator)))
- (integrate/access-operator operations environment operator operands))
+ (integrate/access-operator expression operations environment
+ operator operands))
((and (constant? operator)
(eq? (constant/value operator) (ucode-primitive apply))
(integrate/hack-apply? operands))
=> (lambda (operands*)
- (integrate/combination operations environment
+ (integrate/combination expression
+ operations environment
(car operands*) (cdr operands*))))
(else
(combination/optimizing-make
+ expression
(if (procedure? operator)
- (integrate/procedure-operator operations
- environment
- operator
- operands)
+ (integrate/procedure-operator operations environment
+ operator operands)
(let ((operator
(integrate/expression operations environment operator)))
(if (procedure? operator)
- (integrate/procedure-operator operations
- environment
- operator
- operands)
+ (integrate/procedure-operator operations environment
+ operator operands)
operator)))
operands))))
-(define (integrate/procedure-operator operations environment procedure
- operands)
+(define (integrate/procedure-operator operations environment
+ procedure operands)
(integrate/procedure operations
(simulate-application environment procedure operands)
procedure))
(let ((declarations (declaration/declarations declaration))
(expression (declaration/expression declaration)))
(declaration/make
+ (declaration/scode declaration)
declarations
(integrate/expression (declarations/bind operations declarations)
environment
(if (null? (constant/value predicate))
alternative
consequent)
- (conditional/make predicate consequent alternative)))))
+ (conditional/make (conditional/scode expression)
+ predicate consequent alternative)))))
;; Optimize (or () a) => a; (or #t a) => #t
(if (null? (constant/value predicate))
alternative
predicate)
- (disjunction/make predicate alternative)))))
+ (disjunction/make (disjunction/scode expression)
+ predicate alternative)))))
\f
(define-method/integrate 'SEQUENCE
(lambda (operations environment expression)
;; Optimize (begin (foo)) => (foo)
;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar))
(sequence/optimizing-make
+ expression
(integrate/actions operations environment
(sequence/actions expression)))))
(integrate/expression operations environment action)))
(integrate/actions operations environment (cdr actions))))))
-(define (sequence/optimizing-make actions)
+(define (sequence/optimizing-make expression actions)
(let ((actions (remove-non-side-effecting actions)))
(if (null? (cdr actions))
(car actions)
- (sequence/make actions))))
+ (sequence/make (and expression (object/scode expression))
+ actions))))
(define (remove-non-side-effecting actions)
;; Do not remove references from sequences, because they have
(if (system-global-environment? environment*)
(let ((entry (assq name usual-integrations/constant-alist)))
(if entry
- (cdr entry)
- (access/make environment* name)))
- (access/make (integrate/expression operations environment
+ (constant/make (access/scode expression)
+ (constant/value (cdr entry)))
+ (access/make (access/scode expression)
+ environment* name)))
+ (access/make (access/scode expression)
+ (integrate/expression operations environment
environment*)
- name)))))
+ name)))))
(define (system-global-environment? expression)
(and (constant? expression)
(define-method/integrate 'DELAY
(lambda (operations environment expression)
(delay/make
+ (delay/scode expression)
(integrate/expression operations environment
(delay/expression expression)))))
(define-method/integrate 'IN-PACKAGE
(lambda (operations environment expression)
- (in-package/make (integrate/expression operations environment
+ (in-package/make (in-package/scode expression)
+ (integrate/expression operations environment
(in-package/environment expression))
(integrate/quotation (in-package/quotation expression)))))
(define (integrate/quotation quotation)
(call-with-values
(lambda ()
- (integrate/top-level (quotation/block quotation)
- (quotation/expression quotation)))
+ (integrate/top-level* (quotation/scode quotation)
+ (quotation/block quotation)
+ (quotation/expression quotation)))
(lambda (operations environment expression)
operations environment ;ignore
expression)))
-(define (integrate/access-operator operations environment operator operands)
+(define (integrate/access-operator expression operations
+ environment operator operands)
(let ((name (access/name operator))
(dont-integrate
(lambda ()
- (combination/make operator operands))))
+ (combination/make (and expression (object/scode expression))
+ operator operands))))
(cond ((and (eq? name 'APPLY)
(integrate/hack-apply? operands))
=> (lambda (operands*)
- (integrate/combination operations environment
+ (integrate/combination expression
+ operations environment
(car operands*) (cdr operands*))))
((assq name usual-integrations/constant-alist)
=> (lambda (entry)
- (integrate/combination operations environment
+ (integrate/combination expression
+ operations environment
(cdr entry) operands)))
((assq name usual-integrations/expansion-alist)
=> (lambda (entry)
- ((cdr entry) operands identity-procedure
- dont-integrate false)))
+ ((cdr entry) expression operands
+ identity-procedure dont-integrate false)))
(else
(dont-integrate)))))
\f
vals)
(values environment (map delayed-integration/force vals)))))
-(define (integrate/name reference info environment if-integrated if-not)
+(define (integrate/name expr reference info environment if-integrated if-not)
(let ((variable (reference/variable reference)))
(let ((finish
(lambda (value)
(if-integrated
- (copy/expression/intern (reference/block reference) value)))))
+ (reassign
+ expr
+ (copy/expression/intern (reference/block reference) value))))))
(if info
(finish (integration-info/expression info))
(environment/lookup environment variable
\f
(define (simulate-application environment procedure operands)
(define (procedure->pretty procedure)
- (let ((arg-list (append (procedure/required procedure)
- (if (null? (procedure/optional procedure))
- '()
- (cons lambda-optional-tag
- (procedure/optional procedure)))
- (if (not (procedure/rest procedure))
- '()
- (procedure/rest procedure)))))
- (if (procedure/name procedure)
- `(named-lambda (,(procedure/name procedure) ,@arg-list)
- ...)
- `(lambda ,arg-list
- ...))))
+ (if (procedure/scode procedure)
+ (unsyntax (procedure/scode procedure))
+ (let ((arg-list (append (procedure/required procedure)
+ (if (null? (procedure/optional procedure))
+ '()
+ (cons lambda-optional-tag
+ (procedure/optional procedure)))
+ (if (not (procedure/rest procedure))
+ '()
+ (procedure/rest procedure)))))
+ (if (procedure/name procedure)
+ `(named-lambda (,(procedure/name procedure) ,@arg-list)
+ ...)
+ `(lambda ,arg-list
+ ...)))))
(define (match-required environment required operands)
(cond ((null? required)
(cdr operands)))))
(define (listify-tail operands)
- (let ((const-null (constant/make '())))
+ (let ((const-null (constant/make false '())))
(if (null? operands)
const-null
- (let ((const-cons (constant/make (ucode-primitive cons))))
+ (let ((const-cons (constant/make false (ucode-primitive cons))))
(let walk ((operands operands))
(if (null? operands)
const-null
- (combination/make const-cons
+ (combination/make false const-cons
(list (car operands)
(walk (cdr operands))))))))))
;;; Actually, we really don't want to hack with these for various
;;; reasons
-(define (combination/optimizing-make operator operands)
+(define (combination/optimizing-make expression operator operands)
(cond (
;; fold constants
(and (foldable-operator? operator)
(foldable-constants? operands))
- (constant/make (apply (constant/value operator)
+ (constant/make (and expression (object/scode expression))
+ (apply (constant/value operator)
(map foldable-constant-value operands))))
(
;; optimizing into
;; (foo bar (define (baz) ..) ..)
(not (open-block? (procedure/body operator))))
- (procedure/body operator)
+ (reassign expression (procedure/body operator))
(combination/make
+ (and expression (object/scode expression))
(procedure/make
+ (procedure/scode operator)
(procedure/block operator)
(procedure/name operator)
required
(if (null? unreferenced-operands)
form
(sequence/optimizing-make
+ expression
(append unreferenced-operands (list form))))))))
(else
- (combination/make operator operands))))
+ (combination/make (and expression (object/scode expression))
+ operator operands))))
\f
(define (delete-unreferenced-parameters parameters rest body operands receiver)
(let ((free-in-body (free/expression body)))
;; 5 Re-optimize the code in the body. This can help if the
;; eta-substitution-switch is on.
-(define (open-block/optimizing-make block vars values actions
- operations environment)
+(define (open-block/optimizing-make expression block vars values
+ actions operations environment)
(if (and *block-optimizing-switch
(block/safe? block))
(let ((table:var->vals (associate-vars-and-vals vars values))
;; (print-template template)
(integrate/expression
operations environment
- (build-new-code template
+ (build-new-code expression
+ template
(block/parent block)
table:var->vals actions))))))
- (open-block/make block vars values actions #t)))
+ (open-block/make
+ (and expression (object/scode expression))
+ block vars values actions #t)))
#|
(define (print-template template)
(define (linearize graph)
(collapse-parallel-nodelist 0 (%node-needs graph)))
-(define (build-new-code template parent vars->vals actions)
- (let ((body (sequence/optimizing-make (get-body actions))))
+(define (build-new-code expression template parent vars->vals actions)
+ (let ((body (sequence/optimizing-make expression (get-body actions))))
(let loop ((template template)
(block parent)
(code body))
(loop (cdr template)
block
(combination/optimizing-make
+ (and expression (object/scode expression))
(procedure/make
+ false
block
lambda-tag:let
this-vars
(loop (cdr template)
block
(open-block/make
+ (and expression (object/scode expression))
block this-vars this-vals
(append (make-list
(length this-vals)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 4.2 1991/04/20 06:10:10 cph Exp $
+$Id: usicon.scm,v 4.3 1993/08/03 03:09:51 gjr Exp $
-Copyright (c) 1987-91 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; SCode Optimizer: Usual Integrations: Constants
+;;; package: (scode-optimizer)
(declare (usual-integrations)
(integrate-external "object"))
(map (lambda (name)
(cons name
(constant/make
+ false
(lexical-reference system-global-environment name))))
usual-integrations/constant-names))
'DONE)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: usiexp.scm,v 4.14 1993/01/02 07:33:39 cph Exp $
+$Id: usiexp.scm,v 4.15 1993/08/03 03:09:53 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
\f
;;;; Fixed-arity arithmetic primitives
-(define (make-combination primitive operands)
- (combination/make (constant/make primitive) operands))
+(define (make-combination expression primitive operands)
+ (combination/make (and expression
+ (object/scode expression))
+ (constant/make false primitive)
+ operands))
(define (constant-eq? expression constant)
(and (constant? expression)
(eq? (constant/value expression) constant)))
(define (unary-arithmetic primitive)
- (lambda (operands if-expanded if-not-expanded block)
+ (lambda (expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(null? (cdr operands)))
- (if-expanded (make-combination primitive operands))
+ (if-expanded (make-combination expr primitive operands))
(if-not-expanded))))
(define (binary-arithmetic primitive)
- (lambda (operands if-expanded if-not-expanded block)
+ (lambda (expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
- (if-expanded (make-combination primitive operands))
+ (if-expanded (make-combination expr primitive operands))
(if-not-expanded))))
(define zero?-expansion
;;;; N-ary Arithmetic Predicates
(define (pairwise-test binary-predicate if-left-zero if-right-zero)
- (lambda (operands if-expanded if-not-expanded block)
+ (lambda (expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(cond ((constant-eq? (car operands) 0)
- (make-combination if-left-zero (list (cadr operands))))
+ (make-combination expr if-left-zero (list (cadr operands))))
((constant-eq? (cadr operands) 0)
- (make-combination if-right-zero (list (car operands))))
+ (make-combination expr if-right-zero (list (car operands))))
(else
- (make-combination binary-predicate operands))))
+ (make-combination expr binary-predicate operands))))
(if-not-expanded))))
(define (pairwise-test-inverse inverse-expansion)
- (lambda (operands if-expanded if-not-expanded block)
- (inverse-expansion operands
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (inverse-expansion
+ expr operands
(lambda (expression)
(if-expanded
- (make-combination (ucode-primitive not) (list expression))))
+ (make-combination expr (ucode-primitive not) (list expression))))
if-not-expanded
block)))
\f
;;;; Fixnum Operations
-(define (fix:zero?-expansion operands if-expanded if-not-expanded block)
+(define (fix:zero?-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands) (null? (cdr operands)))
(if-expanded
- (make-combination (ucode-primitive eq?)
- (list (car operands) (constant/make 0))))
+ (make-combination expr (ucode-primitive eq?)
+ (list (car operands) (constant/make false 0))))
(if-not-expanded)))
-(define (fix:=-expansion operands if-expanded if-not-expanded block)
+(define (fix:=-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
- (if-expanded (make-combination (ucode-primitive eq?) operands))
+ (if-expanded (make-combination expr (ucode-primitive eq?) operands))
(if-not-expanded)))
(define char=?-expansion
fix:=-expansion)
-(define (fix:<=-expansion operands if-expanded if-not-expanded block)
+(define (fix:<=-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(make-combination
+ expr
(ucode-primitive not)
- (list (make-combination (ucode-primitive greater-than-fixnum?)
+ (list (make-combination false
+ (ucode-primitive greater-than-fixnum?)
operands))))
(if-not-expanded)))
-(define (fix:>=-expansion operands if-expanded if-not-expanded block)
+(define (fix:>=-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(make-combination
+ expr
(ucode-primitive not)
- (list (make-combination (ucode-primitive less-than-fixnum?)
+ (list (make-combination false
+ (ucode-primitive less-than-fixnum?)
operands))))
(if-not-expanded)))
\f
;;;; N-ary Arithmetic Field Operations
(define (right-accumulation identity make-binary)
- (lambda (operands if-expanded if-not-expanded block)
+ (lambda (expr operands if-expanded if-not-expanded block)
block ; ignored
(let ((operands (delq identity operands)))
(let ((n (length operands)))
(cond ((zero? n)
- (if-expanded (constant/make identity)))
+ (if-expanded (constant/make
+ (and expr (object/scode expr))
+ identity)))
((< n 5)
(if-expanded
(let loop
- ((first (car operands))
+ ((expr expr)
+ (first (car operands))
(rest (cdr operands)))
(if (null? rest)
first
- (make-binary first
- (loop (car rest) (cdr rest)))))))
+ (make-binary expr
+ first
+ (loop false (car rest) (cdr rest)))))))
(else
(if-not-expanded)))))))
(define +-expansion
(right-accumulation 0
- (lambda (x y)
+ (lambda (expr x y)
(cond ((constant-eq? x 1)
- (make-combination (ucode-primitive 1+) (list y)))
+ (make-combination expr (ucode-primitive 1+) (list y)))
((constant-eq? y 1)
- (make-combination (ucode-primitive 1+) (list x)))
+ (make-combination expr (ucode-primitive 1+) (list x)))
(else
- (make-combination (ucode-primitive &+) (list x y)))))))
+ (make-combination expr (ucode-primitive &+) (list x y)))))))
(define *-expansion
(right-accumulation 1
- (lambda (x y)
- (make-combination (ucode-primitive &*) (list x y)))))
+ (lambda (expr x y)
+ (make-combination expr (ucode-primitive &*) (list x y)))))
\f
(define (right-accumulation-inverse identity inverse-expansion make-binary)
- (lambda (operands if-expanded if-not-expanded block)
+ (lambda (expr operands if-expanded if-not-expanded block)
(let ((expand
- (lambda (x y)
+ (lambda (expr x y)
(if-expanded
(if (constant-eq? y identity)
x
- (make-binary x y))))))
+ (make-binary expr x y))))))
(cond ((null? operands)
(if-not-expanded))
((null? (cdr operands))
- (expand (constant/make identity) (car operands)))
+ (expand expr (constant/make false identity) (car operands)))
(else
- (inverse-expansion (cdr operands)
+ (inverse-expansion false (cdr operands)
(lambda (expression)
- (expand (car operands) expression))
+ (expand expr (car operands) expression))
if-not-expanded
block))))))
(define --expansion
(right-accumulation-inverse 0 +-expansion
- (lambda (x y)
+ (lambda (expr x y)
(if (constant-eq? y 1)
- (make-combination (ucode-primitive -1+) (list x))
- (make-combination (ucode-primitive &-) (list x y))))))
+ (make-combination expr (ucode-primitive -1+) (list x))
+ (make-combination expr (ucode-primitive &-) (list x y))))))
(define /-expansion
(right-accumulation-inverse 1 *-expansion
- (lambda (x y)
- (make-combination (ucode-primitive &/) (list x y)))))
+ (lambda (expr x y)
+ (make-combination expr (ucode-primitive &/) (list x y)))))
\f
;;;; N-ary List Operations
-(define (apply*-expansion operands if-expanded if-not-expanded block)
+(define (apply*-expansion expr operands if-expanded if-not-expanded block)
block
(if (< 1 (length operands) 10)
(if-expanded
(combination/make
+ (and expr (object/scode expr))
(global-ref/make 'APPLY)
- (list (car operands) (cons*-expansion-loop (cdr operands)))))
+ (list (car operands) (cons*-expansion-loop false (cdr operands)))))
(if-not-expanded)))
-(define (cons*-expansion operands if-expanded if-not-expanded block)
+(define (cons*-expansion expr operands if-expanded if-not-expanded block)
block
(if (< -1 (length operands) 9)
- (if-expanded (cons*-expansion-loop operands))
+ (if-expanded (cons*-expansion-loop expr operands))
(if-not-expanded)))
-(define (cons*-expansion-loop rest)
+(define (cons*-expansion-loop expr rest)
(if (null? (cdr rest))
(car rest)
- (make-combination (ucode-primitive cons)
+ (make-combination expr
+ (ucode-primitive cons)
(list (car rest)
- (cons*-expansion-loop (cdr rest))))))
+ (cons*-expansion-loop false (cdr rest))))))
-(define (list-expansion operands if-expanded if-not-expanded block)
+(define (list-expansion expr operands if-expanded if-not-expanded block)
block ; ignored
(if (< (length operands) 9)
- (if-expanded (list-expansion-loop operands))
+ (if-expanded (list-expansion-loop expr operands))
(if-not-expanded)))
-(define (list-expansion-loop rest)
+(define (list-expansion-loop expr rest)
(if (null? rest)
- (constant/make '())
- (make-combination (ucode-primitive cons)
+ (constant/make (and expr (object/scode expr)) '())
+ (make-combination expr (ucode-primitive cons)
(list (car rest)
- (list-expansion-loop (cdr rest))))))
+ (list-expansion-loop false (cdr rest))))))
-(define (values-expansion operands if-expanded if-not-expanded block)
+(define (values-expansion expr operands if-expanded if-not-expanded block)
if-not-expanded
(if-expanded
(let ((block (block/make block true '())))
(string->uninterned-symbol "value")))
operands)))
(combination/make
+ (and expr (object/scode expr))
(procedure/make
+ false
block lambda-tag:let variables '() false
(let ((block (block/make block true '())))
(let ((variable (variable/make&bind! block 'RECEIVER)))
(procedure/make
- block lambda-tag:unnamed (list variable) '() false
- (combination/make (reference/make block variable)
+ false block lambda-tag:unnamed (list variable) '() false
+ (combination/make false
+ (reference/make false block variable)
(map (lambda (variable)
- (reference/make block variable))
+ (reference/make false block variable))
variables))))))
operands)))))
-(define (call-with-values-expansion operands if-expanded if-not-expanded block)
+(define (call-with-values-expansion expr operands
+ if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
- (combination/make (combination/make (car operands) '())
+ (combination/make (and expr (object/scode expr))
+ (combination/make false (car operands) '())
(cdr operands)))
(if-not-expanded)))
\f
;;;; General CAR/CDR Encodings
(define (general-car-cdr-expansion encoding)
- (lambda (operands if-expanded if-not-expanded block)
+ (lambda (expr operands if-expanded if-not-expanded block)
block
(if (= (length operands) 1)
(if-expanded
- (make-combination (ucode-primitive general-car-cdr)
+ (make-combination expr
+ (ucode-primitive general-car-cdr)
(list (car operands)
- (constant/make encoding))))
+ (constant/make false encoding))))
(if-not-expanded))))
(define caar-expansion (general-car-cdr-expansion #b111))
\f
;;;; Miscellaneous
-(define (make-string-expansion operands if-expanded if-not-expanded block)
+(define (make-string-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
- (make-combination (ucode-primitive string-allocate) operands))
+ (make-combination expr (ucode-primitive string-allocate) operands))
(if-not-expanded)))
(define (type-test-expansion type)
- (lambda (operands if-expanded if-not-expanded block)
+ (lambda (expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(null? (cdr operands)))
- (if-expanded (make-type-test type (car operands)))
+ (if-expanded (make-type-test expr type (car operands)))
(if-not-expanded))))
(define char?-expansion (type-test-expansion (ucode-type character)))
(define flo:flonum?-expansion (type-test-expansion (ucode-type big-flonum)))
(define fix:fixnum?-expansion (type-test-expansion (ucode-type fixnum)))
-(define (exact-integer?-expansion operands if-expanded if-not-expanded block)
+(define (exact-integer?-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-disjunction
- (make-type-test (ucode-type fixnum) (car operands))
- (make-type-test (ucode-type big-fixnum) (car operands))))
+ expr
+ (make-type-test false (ucode-type fixnum) (car operands))
+ (make-type-test false (ucode-type big-fixnum) (car operands))))
(if-not-expanded)))
-(define (exact-rational?-expansion operands if-expanded if-not-expanded block)
+(define (exact-rational?-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-disjunction
- (make-type-test (ucode-type fixnum) (car operands))
- (make-type-test (ucode-type big-fixnum) (car operands))
- (make-type-test (ucode-type ratnum) (car operands))))
+ expr
+ (make-type-test false (ucode-type fixnum) (car operands))
+ (make-type-test false (ucode-type big-fixnum) (car operands))
+ (make-type-test false (ucode-type ratnum) (car operands))))
(if-not-expanded)))
-(define (complex?-expansion operands if-expanded if-not-expanded block)
+(define (complex?-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-disjunction
- (make-type-test (ucode-type fixnum) (car operands))
- (make-type-test (ucode-type big-fixnum) (car operands))
- (make-type-test (ucode-type ratnum) (car operands))
- (make-type-test (ucode-type big-flonum) (car operands))
- (make-type-test (ucode-type recnum) (car operands))))
+ expr
+ (make-type-test false (ucode-type fixnum) (car operands))
+ (make-type-test false (ucode-type big-fixnum) (car operands))
+ (make-type-test false (ucode-type ratnum) (car operands))
+ (make-type-test false (ucode-type big-flonum) (car operands))
+ (make-type-test false (ucode-type recnum) (car operands))))
(if-not-expanded)))
-(define (make-disjunction . clauses)
+(define (make-disjunction expr . clauses)
(let loop ((clauses clauses))
(if (null? (cdr clauses))
(car clauses)
- (disjunction/make (car clauses) (loop (cdr clauses))))))
+ (disjunction/make (and expr (object/scode expr))
+ (car clauses) (loop (cdr clauses))))))
+(define (make-type-test expr type operand)
+ (make-combination expr
+ (ucode-primitive object-type?)
+ (list (constant/make false type) operand)))
-(define (make-type-test type operand)
- (make-combination (ucode-primitive object-type?)
- (list (constant/make type) operand)))
-
-(define (string->symbol-expansion operands if-expanded if-not-expanded block)
+(define (string->symbol-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(string? (car operands))
(null? (cdr operands)))
- (if-expanded (constant/make (string->symbol (car operands))))
+ (if-expanded
+ (constant/make (and expr (object/scode expr))
+ (string->symbol (car operands))))
(if-not-expanded)))
\f
;;;; Tables
;;; Scode->Scode expanders
(define (scode->scode-expander scode-expander)
- (lambda (operands if-expanded if-not-expanded block)
+ (lambda (expr operands if-expanded if-not-expanded block)
(scode-expander
(map cgen/external-with-declarations operands)
(lambda (scode-expression)
(if-expanded
- (transform/recursive
- block
- (integrate/get-top-level-block)
- scode-expression)))
+ (reassign
+ expr
+ (transform/recursive
+ block
+ (integrate/get-top-level-block)
+ scode-expression))))
if-not-expanded)))
;;; Kludge for EXPAND-OPERATOR declaration.
#| -*-Scheme-*-
-$Id: xform.scm,v 4.4 1993/01/02 07:33:39 cph Exp $
+$Id: xform.scm,v 4.5 1993/08/03 03:09:54 gjr Exp $
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; SCode Optimizer: Transform Input Expression
+;;; package: (scode-optimizer transform)
(declare (usual-integrations)
(integrate-external "object"))
(call-with-values
(lambda () (open-block-components expression values))
(lambda (auxiliary declarations body)
- (transform/open-block* block
+ (transform/open-block* expression
+ block
environment
auxiliary
declarations
(define (transform/open-block block environment expression)
(call-with-values (lambda () (open-block-components expression values))
(lambda (auxiliary declarations body)
- (transform/open-block* (block/make block true '())
+ (transform/open-block* expression
+ (block/make block true '())
environment
auxiliary
declarations
body))))
-(define (transform/open-block* block environment auxiliary declarations body)
+(define (transform/open-block* expression block environment auxiliary declarations body)
(let ((variables
(map (lambda (name) (variable/make&bind! block name))
auxiliary)))
(cons (transform (car actions))
actions*))))))))))
(lambda (vals actions)
- (open-block/make block variables vals actions false)))))
+ (open-block/make expression block variables vals actions false)))))
(define (transform/variable block environment expression)
- (reference/make block
+ (reference/make expression
+ block
(environment/lookup environment
(variable-name expression))))
(lambda (name value)
(let ((variable (environment/lookup environment name)))
(variable/side-effect! variable)
- (assignment/make block
+ (assignment/make expression
+ block
variable
(transform/expression block environment value))))))
\f
(environment/bind environment
(block/bound-variables-list block))))
(procedure/make
- block name required optional rest
+ expression block name required optional rest
(transform/procedure-body block
environment
body)))))))))
(lambda (name value)
(if (not (eq? block top-level-block))
(error "Unscanned definition encountered (unable to proceed):" name))
- (transform/combination
- block environment
+ (transform/combination*
+ expression block environment
(make-combination (make-primitive-procedure 'LOCAL-ASSIGNMENT)
(list (make-the-environment) name value))))))
(define (transform/access block environment expression)
(access-components expression
(lambda (environment* name)
- (access/make (transform/expression block environment environment*)
+ (access/make expression
+ (transform/expression block environment environment*)
name))))
(define (transform/combination block environment expression)
- (combination-components expression
+ (transform/combination* expression block environment expression))
+
+(define (transform/combination* expression block environment expression*)
+ (combination-components expression*
(lambda (operator operands)
- (combination/make (transform/expression block environment operator)
+ (combination/make expression
+ (transform/expression block environment operator)
(transform/expressions block environment operands)))))
(define (transform/comment block environment expression)
(conditional-components expression
(lambda (predicate consequent alternative)
(conditional/make
+ expression
(transform/expression block environment predicate)
(transform/expression block environment consequent)
(transform/expression block environment alternative)))))
(define (transform/constant block environment expression)
block environment ; ignored
- (constant/make expression))
+ (constant/make expression expression))
(define (transform/declaration block environment expression)
(declaration-components expression
- (lambda (declarations expression)
- (declaration/make (declarations/parse block declarations)
- (transform/expression block environment expression)))))
+ (lambda (declarations expression*)
+ (declaration/make expression
+ (declarations/parse block declarations)
+ (transform/expression block environment expression*)))))
(define (transform/delay block environment expression)
(delay/make
+ expression
(transform/expression block environment (delay-expression expression))))
(define (transform/disjunction block environment expression)
(disjunction-components expression
(lambda (predicate alternative)
(disjunction/make
+ expression
(transform/expression block environment predicate)
(transform/expression block environment alternative)))))
(define (transform/in-package block environment expression)
(in-package-components expression
- (lambda (environment* expression)
- (in-package/make (transform/expression block environment environment*)
- (transform/quotation* expression)))))
+ (lambda (environment* expression*)
+ (in-package/make expression
+ (transform/expression block environment environment*)
+ (transform/quotation* false expression*)))))
(define (transform/quotation block environment expression)
block environment ;ignored
- (transform/quotation* (quotation-expression expression)))
+ (transform/quotation* expression (quotation-expression expression)))
-(define (transform/quotation* expression)
- (call-with-values (lambda () (transform/top-level expression '()))
- quotation/make))
+(define (transform/quotation* expression expression*)
+ (call-with-values
+ (lambda () (transform/top-level expression* '()))
+ (lambda (block expression**)
+ (quotation/make expression block expression**))))
(define (transform/sequence block environment expression)
(sequence/make
+ expression
(transform/expressions block environment (sequence-actions expression))))
(define (transform/the-environment block environment expression)
- environment expression ; ignored
+ environment ; ignored
(block/unsafe! block)
- (the-environment/make block))
+ (the-environment/make expression block))
(define transform/dispatch
(make-scode-walker
projects / mit-scheme.git / commitdiff