From: Guillermo J. Rozas Date: Tue, 3 Aug 1993 03:09:54 +0000 (+0000) Subject: Add a mechanism for mapping input scode objects to output scode X-Git-Tag: 20090517-FFI~8142 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3dba9c2f7aee9f38eed347afadd5d43db323e809;p=mit-scheme.git Add a mechanism for mapping input scode objects to output scode objects. The original scode objects are passed through to the output, and the *sf-associate* hook is called on the output scode and the original scode. The default *sf-associate* does nothing. --- diff --git a/v7/src/sf/cgen.scm b/v7/src/sf/cgen.scm index c33db2ac1..ff5502e69 100644 --- a/v7/src/sf/cgen.scm +++ b/v7/src/sf/cgen.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Generate SCode from Expression +;;; package: (scode-optimizer cgen) (declare (usual-integrations) (automagic-integrations) @@ -40,9 +41,19 @@ MIT in each case. |# (eta-substitution) (integrate-external "object")) +(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)) @@ -91,9 +102,14 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/copy.scm b/v7/src/sf/copy.scm index 391febbde..3fd071831 100644 --- a/v7/src/sf/copy.scm +++ b/v7/src/sf/copy.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Copy Expression +;;; package: (scode-optimizer copy) (declare (usual-integrations) (integrate-external "object")) @@ -98,7 +99,8 @@ MIT in each case. |# (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)))))) @@ -175,7 +177,8 @@ MIT in each case. |# (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)))) @@ -183,6 +186,7 @@ MIT in each case. |# (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))))) @@ -190,12 +194,14 @@ MIT in each case. |# (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 @@ -210,6 +216,7 @@ MIT in each case. |# (define-method/copy 'DECLARATION (lambda (block environment expression) (declaration/make + (declaration/scode expression) (copy/declarations block environment (declaration/declarations expression)) @@ -218,11 +225,13 @@ MIT in each case. |# (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 @@ -231,6 +240,7 @@ MIT in each case. |# (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))))) @@ -241,7 +251,8 @@ MIT in each case. |# (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)) @@ -259,6 +270,7 @@ MIT in each case. |# (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)) @@ -276,13 +288,15 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm index 79f816c89..913af0026 100644 --- a/v7/src/sf/object.scm +++ b/v7/src/sf/object.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -133,13 +133,16 @@ MIT in each case. |# (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)) @@ -156,11 +159,21 @@ MIT in each case. |# (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)) ;;;; Miscellany @@ -203,7 +216,9 @@ MIT in each case. |# (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) @@ -213,7 +228,7 @@ MIT in each case. |# (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) diff --git a/v7/src/sf/sf.pkg b/v7/src/sf/sf.pkg index 9a4801ec5..6b702b957 100644 --- a/v7/src/sf/sf.pkg +++ b/v7/src/sf/sf.pkg @@ -1,8 +1,8 @@ #| -*-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 @@ -93,6 +93,7 @@ MIT in each case. |# (export (scode-optimizer) integrate/top-level integrate/get-top-level-block + reassign variable/final-value) (import (runtime parser) lambda-optional-tag)) @@ -101,6 +102,7 @@ MIT in each case. |# (files "cgen") (parent (scode-optimizer)) (export (scode-optimizer) + *sf-associate* cgen/external) (export (scode-optimizer expansion) cgen/external-with-declarations)) diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm index 79a73dda3..c9bd3a2ae 100644 --- a/v7/src/sf/subst.scm +++ b/v7/src/sf/subst.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -48,6 +48,9 @@ MIT in each case. |# (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 @@ -67,7 +70,10 @@ MIT in each case. |# 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) @@ -101,7 +107,8 @@ MIT in each case. |# ;; 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 @@ -122,7 +129,8 @@ MIT in each case. |# 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 @@ -132,9 +140,8 @@ MIT in each case. |# (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 @@ -144,8 +151,8 @@ MIT in each case. |# (try-safe-integration) (integration-failure)))))))) -(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)))) @@ -154,8 +161,10 @@ MIT in each case. |# (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) @@ -167,6 +176,12 @@ MIT in each case. |# (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) @@ -191,7 +206,8 @@ MIT in each case. |# ;; not found variable true))))))))) -(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 () @@ -199,15 +215,17 @@ MIT in each case. |# (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 @@ -215,13 +233,15 @@ MIT in each case. |# (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 @@ -269,10 +289,13 @@ MIT in each case. |# (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) @@ -387,7 +410,8 @@ you ask for. (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 @@ -403,52 +427,48 @@ you ask for. (and (reference? this-operand) (eq? (reference/variable this-operand) this-required) (match-up? (cdr operands) (cdr required))))))) - (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)) @@ -458,6 +478,7 @@ you ask for. (let ((declarations (declaration/declarations declaration)) (expression (declaration/expression declaration))) (declaration/make + (declaration/scode declaration) declarations (integrate/expression (declarations/bind operations declarations) environment @@ -500,7 +521,8 @@ you ask for. (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 @@ -515,13 +537,15 @@ you ask for. (if (null? (constant/value predicate)) alternative predicate) - (disjunction/make predicate alternative))))) + (disjunction/make (disjunction/scode expression) + predicate alternative))))) (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))))) @@ -542,11 +566,12 @@ you ask for. (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 @@ -577,11 +602,14 @@ you ask for. (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) @@ -590,42 +618,49 @@ you ask for. (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))))) @@ -646,12 +681,14 @@ you ask for. 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 @@ -731,19 +768,21 @@ you ask for. (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) @@ -774,14 +813,14 @@ you ask for. (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)))))))))) @@ -899,12 +938,13 @@ forms are simply removed. ;;; 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)))) ( @@ -935,9 +975,11 @@ forms are simply removed. ;; 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 @@ -948,9 +990,11 @@ forms are simply removed. (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)))) (define (delete-unreferenced-parameters parameters rest body operands receiver) (let ((free-in-body (free/expression body))) @@ -1008,8 +1052,8 @@ forms are simply removed. ;; 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)) @@ -1030,10 +1074,13 @@ forms are simply removed. ;; (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) @@ -1332,8 +1379,8 @@ forms are simply removed. (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)) @@ -1354,7 +1401,9 @@ forms are simply removed. (loop (cdr template) block (combination/optimizing-make + (and expression (object/scode expression)) (procedure/make + false block lambda-tag:let this-vars @@ -1366,6 +1415,7 @@ forms are simply removed. (loop (cdr template) block (open-block/make + (and expression (object/scode expression)) block this-vars this-vals (append (make-list (length this-vals) diff --git a/v7/src/sf/usicon.scm b/v7/src/sf/usicon.scm index be231852d..feb394fea 100644 --- a/v7/src/sf/usicon.scm +++ b/v7/src/sf/usicon.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Usual Integrations: Constants +;;; package: (scode-optimizer) (declare (usual-integrations) (integrate-external "object")) @@ -80,6 +81,7 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index dbe8e61d9..8a3acdc53 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -40,28 +40,31 @@ MIT in each case. |# ;;;; 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 @@ -91,26 +94,27 @@ MIT in each case. |# ;;;; 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))) @@ -134,154 +138,164 @@ MIT in each case. |# ;;;; 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))) ;;;; 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))))) (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))))) ;;;; 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 '()))) @@ -292,38 +306,44 @@ MIT in each case. |# (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))) ;;;; 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)) @@ -367,20 +387,20 @@ MIT in each case. |# ;;;; 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))) @@ -390,57 +410,63 @@ MIT in each case. |# (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))) ;;;; Tables @@ -617,15 +643,17 @@ MIT in each case. |# ;;; 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. diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm index 76853eb5f..aeebea58c 100644 --- a/v7/src/sf/xform.scm +++ b/v7/src/sf/xform.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Transform Input Expression +;;; package: (scode-optimizer transform) (declare (usual-integrations) (integrate-external "object")) @@ -67,7 +68,8 @@ MIT in each case. |# (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 @@ -103,13 +105,14 @@ MIT in each case. |# (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))) @@ -149,10 +152,11 @@ MIT in each case. |# (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)))) @@ -161,7 +165,8 @@ MIT in each case. |# (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)))))) @@ -181,7 +186,7 @@ MIT in each case. |# (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))))))))) @@ -203,21 +208,26 @@ MIT in each case. |# (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) @@ -227,53 +237,61 @@ MIT in each case. |# (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