From bb3a2e9f038b3d8fff292f7b6b36d5a5e00b7bb1 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Tue, 22 Mar 1988 17:40:50 +0000 Subject: [PATCH] automagic-integrations --- v7/src/sf/cgen.scm | 12 +- v7/src/sf/chtype.scm | 19 +- v7/src/sf/copy.scm | 20 +- v7/src/sf/emodel.scm | 2 +- v7/src/sf/free.scm | 89 ++-- v7/src/sf/gconst.scm | 2 +- v7/src/sf/make.scm | 51 +- v7/src/sf/object.scm | 41 +- v7/src/sf/pardec.scm | 70 ++- v7/src/sf/pthmap.scm | 9 +- v7/src/sf/subst.scm | 1124 +++++++++++++++++++++++++++++++++++------- v7/src/sf/tables.scm | 3 +- v7/src/sf/toplev.scm | 33 +- v7/src/sf/usicon.scm | 8 +- v7/src/sf/usiexp.scm | 14 +- v7/src/sf/xform.scm | 18 +- v8/src/sf/make.scm | 51 +- v8/src/sf/toplev.scm | 33 +- 18 files changed, 1295 insertions(+), 304 deletions(-) diff --git a/v7/src/sf/cgen.scm b/v7/src/sf/cgen.scm index 38dfa142b..6e4ff09f3 100644 --- a/v7/src/sf/cgen.scm +++ b/v7/src/sf/cgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.4 1987/07/02 20:35:58 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.5 1988/03/22 17:35:09 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,9 @@ MIT in each case. |# ;;;; SCode Optimizer: Generate SCode from Expression (declare (usual-integrations)) +(declare (automagic-integrations)) +(declare (open-block-optimizations)) +(declare (eta-substitution)) (define (cgen/external quotation) (fluid-let ((flush-declarations? true)) @@ -79,6 +82,8 @@ MIT in each case. |# (cgen/expression interns expression)) expressions)) +(declare (integrate-operator cgen/expression)) + (define (cgen/expression interns expression) ((expression/method dispatch-vector expression) interns expression)) @@ -121,6 +126,7 @@ MIT in each case. |# (define-method/cgen 'CONSTANT (lambda (interns expression) + interns ; is ignored (constant/value expression))) (define-method/cgen 'DECLARATION @@ -147,6 +153,7 @@ MIT in each case. |# (define-method/cgen 'PROCEDURE (lambda (interns procedure) + interns ; ignored (make-lambda* (procedure/name procedure) (map variable/name (procedure/required procedure)) (map variable/name (procedure/optional procedure)) @@ -161,6 +168,7 @@ MIT in each case. |# (define-method/cgen 'OPEN-BLOCK (lambda (interns expression) + interns ; is ignored (let ((block (open-block/block expression))) (make-open-block '() (maybe-flush-declarations (block/declarations block)) @@ -184,6 +192,7 @@ MIT in each case. |# (define-method/cgen 'QUOTATION (lambda (interns expression) + interns ; ignored (make-quotation (cgen/top-level expression)))) (define-method/cgen 'REFERENCE @@ -196,4 +205,5 @@ MIT in each case. |# (define-method/cgen 'THE-ENVIRONMENT (lambda (interns expression) + interns expression ; ignored (make-the-environment))) \ No newline at end of file diff --git a/v7/src/sf/chtype.scm b/v7/src/sf/chtype.scm index 157deca2c..c992c1e60 100644 --- a/v7/src/sf/chtype.scm +++ b/v7/src/sf/chtype.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/chtype.scm,v 1.1 1987/03/21 00:23:49 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/chtype.scm,v 1.2 1988/03/22 17:35:34 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,7 @@ MIT in each case. |# ;;;; SCode Optimizer: Intern object types (declare (usual-integrations)) +(declare (automagic-integrations)) (define (change-type/external block expression) (change-type/block block) @@ -51,6 +52,8 @@ MIT in each case. |# (define (change-type/expressions expressions) (for-each change-type/expression expressions)) +(declare (integrate-operator change-type/expression)) + (define (change-type/expression expression) (change-type/object enumeration/expression expression) ((expression/method dispatch-vector expression) expression)) @@ -61,6 +64,8 @@ MIT in each case. |# (define define-method/change-type (expression/make-method-definer dispatch-vector)) +(declare (integrate-operator change-type/object)) + (define (change-type/object enumeration object) (object/set-enumerand! object @@ -88,6 +93,7 @@ MIT in each case. |# (define-method/change-type 'CONSTANT (lambda (expression) + expression ; ignored 'DONE)) (define-method/change-type 'DECLARATION @@ -115,7 +121,14 @@ MIT in each case. |# (define-method/change-type 'OPEN-BLOCK (lambda (expression) (change-type/expressions (open-block/values expression)) - (change-type/expressions (open-block/actions expression)))) + (change-type/open-block-actions (open-block/actions expression)))) + +(define (change-type/open-block-actions actions) + (cond ((null? actions) 'DONE) + ((eq? (car actions) open-block/value-marker) + (change-type/open-block-actions (cdr actions))) + (else (change-type/expression (car actions)) + (change-type/open-block-actions (cdr actions))))) (define-method/change-type 'QUOTATION (lambda (expression) @@ -126,6 +139,7 @@ MIT in each case. |# (define-method/change-type 'REFERENCE (lambda (expression) + expression ; ignored 'DONE)) (define-method/change-type 'SEQUENCE @@ -134,4 +148,5 @@ MIT in each case. |# (define-method/change-type 'THE-ENVIRONMENT (lambda (expression) + expression ; ignored 'DONE)) \ No newline at end of file diff --git a/v7/src/sf/copy.scm b/v7/src/sf/copy.scm index 0c31f31db..3dab4ae0d 100644 --- a/v7/src/sf/copy.scm +++ b/v7/src/sf/copy.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.6 1987/07/08 04:35:44 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.7 1988/03/22 17:36:06 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,9 @@ MIT in each case. |# ;;;; SCode Optimizer: Copy Expression (declare (usual-integrations)) +(declare (open-block-optimizations)) +(declare (eta-substitution)) +(declare (automagic-integrations)) (define root-block) @@ -61,6 +64,8 @@ MIT in each case. |# (copy/expression block environment expression)) expressions)) +(declare (integrate-operator copy/expression)) + (define (copy/expression block environment expression) ((expression/method dispatch-vector expression) block environment expression)) @@ -85,18 +90,22 @@ MIT in each case. |# (old-bound (block/bound-variables block))) (let ((new-bound (map (lambda (variable) - (variable/make result (variable/name variable))) + (variable/make result + (variable/name variable) + (variable/flags variable))) old-bound))) (let ((environment (environment/bind environment old-bound new-bound))) (block/set-bound-variables! result new-bound) (block/set-declarations! result (copy/declarations block environment (block/declarations block))) + (block/set-flags! result (block/flags block)) (return-2 result environment))))) (define copy/variable/free) (define (copy/variable block environment variable) + block ; ignored (environment/lookup environment variable identity-procedure (copy/variable/free variable))) @@ -129,6 +138,7 @@ MIT in each case. |# (define copy/declarations) (define (copy/declarations/intern block environment declarations) + block ; ignored (if (null? declarations) '() (declarations/map declarations @@ -215,6 +225,7 @@ MIT in each case. |# (define-method/copy 'CONSTANT (lambda (block environment expression) + block environment ; ignored expression)) (define-method/copy 'DECLARATION @@ -269,10 +280,12 @@ MIT in each case. |# (if (eq? action open-block/value-marker) action (copy/expression block environment action))) - (open-block/actions expression))))))) + (open-block/actions expression)) + (open-block/optimized expression)))))) (define-method/copy 'QUOTATION (lambda (block environment expression) + block environment ; ignored (copy/quotation expression))) (define-method/copy 'REFERENCE @@ -288,4 +301,5 @@ MIT in each case. |# (define-method/copy 'THE-ENVIRONMENT (lambda (block environment expression) + block environment expression ; ignored (error "Attempt to integrate expression containing (THE-ENVIRONMENT)"))) \ No newline at end of file diff --git a/v7/src/sf/emodel.scm b/v7/src/sf/emodel.scm index 279792dda..df78dfd25 100644 --- a/v7/src/sf/emodel.scm +++ b/v7/src/sf/emodel.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.3 1987/07/08 04:39:27 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.4 1988/03/22 17:36:18 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology diff --git a/v7/src/sf/free.scm b/v7/src/sf/free.scm index 82cb45a88..8e2cf4aef 100644 --- a/v7/src/sf/free.scm +++ b/v7/src/sf/free.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.2 1987/03/13 04:12:30 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.3 1988/03/22 17:36:49 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,12 +35,30 @@ MIT in each case. |# ;;;; SCode Optimizer: Free Variable Analysis (declare (usual-integrations)) +(declare (automagic-integrations)) +(declare (open-block-optimizations)) +(declare (eta-substitution)) + +(declare (integrate-operator no-free-variables singleton-variable + list->variable-set)) + +(define (no-free-variables) + (empty-set variable? eq?)) + +(define (singleton-variable variable) + (singleton-set variable? eq? variable)) + +(define (list->variable-set variable-list) + (list->set variable? eq? variable-list)) + (define (free/expressions expressions) (if (null? expressions) - eq?-set/null - (eq?-set/union (free/expression (car expressions)) - (free/expressions (cdr expressions))))) + (no-free-variables) + (set/union (free/expression (car expressions)) + (free/expressions (cdr expressions))))) + +(declare (integrate-operator free/expression)) (define (free/expression expression) ((expression/method dispatch-vector expression) expression)) @@ -57,24 +75,25 @@ MIT in each case. |# (define-method/free 'ASSIGNMENT (lambda (expression) - (eq?-set/adjoin (assignment/variable expression) - (free/expression (assignment/value expression))))) + (set/adjoin (free/expression (assignment/value expression)) + (assignment/variable expression)))) (define-method/free 'COMBINATION (lambda (expression) - (eq?-set/union (free/expression (combination/operator expression)) - (free/expressions (combination/operands expression))))) + (set/union (free/expression (combination/operator expression)) + (free/expressions (combination/operands expression))))) (define-method/free 'CONDITIONAL (lambda (expression) - (eq?-set/union + (set/union* (free/expression (conditional/predicate expression)) - (eq?-set/union (free/expression (conditional/consequent expression)) - (free/expression (conditional/alternative expression)))))) + (free/expression (conditional/consequent expression)) + (free/expression (conditional/alternative expression))))) (define-method/free 'CONSTANT - (lambda (expression) - eq?-set/null)) + (lambda (expression) + expression + (no-free-variables))) (define-method/free 'DECLARATION (lambda (expression) @@ -86,8 +105,8 @@ MIT in each case. |# (define-method/free 'DISJUNCTION (lambda (expression) - (eq?-set/union (free/expression (disjunction/predicate expression)) - (free/expression (disjunction/alternative expression))))) + (set/union (free/expression (disjunction/predicate expression)) + (free/expression (disjunction/alternative expression))))) (define-method/free 'IN-PACKAGE (lambda (expression) @@ -95,34 +114,38 @@ MIT in each case. |# (define-method/free 'PROCEDURE (lambda (expression) - (eq?-set/difference (free/expression (procedure/body expression)) - (block/bound-variables (procedure/block expression))))) + (set/difference (free/expression (procedure/body expression)) + (list->variable-set + (block/bound-variables (procedure/block expression)))))) (define-method/free 'OPEN-BLOCK (lambda (expression) - (eq?-set/difference - (eq?-set/union (free/expressions (open-block/values expression)) - (let loop ((actions (open-block/actions expression))) - (cond ((null? actions) eq?-set/null) - ((eq? (car actions) open-block/value-marker) - (loop (cdr actions))) - (else - (eq?-set/union (free/expression (car actions)) - (loop (cdr actions))))))) - (block/bound-variables (open-block/block expression))))) + (set/difference + (set/union (free/expressions (open-block/values expression)) + (let loop ((actions (open-block/actions expression))) + (cond ((null? actions) (no-free-variables)) + ((eq? (car actions) open-block/value-marker) + (loop (cdr actions))) + (else + (set/union (free/expression (car actions)) + (loop (cdr actions))))))) + (list->variable-set + (block/bound-variables (open-block/block expression)))))) (define-method/free 'QUOTATION - (lambda (expression) - eq?-set/null)) + (lambda (expression) + expression + (no-free-variables))) (define-method/free 'REFERENCE - (lambda (expression) - (eq?-set/singleton (reference/variable expression)))) + (lambda (expression) + (singleton-variable (reference/variable expression)))) (define-method/free 'SEQUENCE (lambda (expression) (free/expressions (sequence/actions expression)))) (define-method/free 'THE-ENVIRONMENT - (lambda (expression) - eq?-set/null)) \ No newline at end of file + (lambda (expression) + expression + (no-free-variables))) diff --git a/v7/src/sf/gconst.scm b/v7/src/sf/gconst.scm index 9a0611fec..470e32bf5 100644 --- a/v7/src/sf/gconst.scm +++ b/v7/src/sf/gconst.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 3.5 1987/12/23 04:19:28 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 3.6 1988/03/22 17:37:01 jrm Exp $ Copyright (c) 1987 Massachusetts Institute of Technology diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index 0f894fbdd..2cce4dcf0 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.15 1988/02/28 23:00:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.16 1988/03/22 17:37:26 jrm Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -61,45 +61,56 @@ MIT in each case. |# (make-environment (define :name "SF") (define :version 3) - (define :modification 15) + (define :modification 16) (define :files) (define :files-lists (list + (cons system-global-environment + '( + "sfmac.bin" ; Macros for SF + )) (cons package/scode-optimizer - '("mvalue.bin" ;Multiple Value Support - "eqsets.bin" ;Set Data Abstraction - "pthmap.bin" ;Pathname Map Abstraction - "object.bin" ;Data Structures - "emodel.bin" ;Environment Model - "gconst.bin" ;Global Primitives List - "usicon.bin" ;Usual Integrations: Constants - "tables.bin" ;Table Abstractions - "packag.bin" ;Global packaging + '( + "mvalue.bin" ; Multiple Value Support + "lsets.bin" ; Set Data Abstraction + "table.bin" ; Table Abstraction + "pthmap.bin" ; Pathname Map Abstraction + "object.bin" ; Data Structures + "emodel.bin" ; Environment Model + "gconst.bin" ; Global Primitives List + "usicon.bin" ; Usual Integrations: Constants + "tables.bin" ; Operation Table Abstractions + "packag.bin" ; Global packaging )) (cons package/top-level - '("toplev.bin")) ;Top Level + '("toplev.bin")) ; Top Level (cons package/transform - '("xform.bin")) ;SCode -> Internal + '("xform.bin")) ; SCode -> Internal (cons package/integrate - '("subst.bin")) ;Beta Substitution Optimizer + '("subst.bin")) ; Beta Substitution Optimizer (cons package/cgen - '("cgen.bin")) ;Internal -> SCode + '("cgen.bin")) ; Internal -> SCode (cons package/expansion - '("usiexp.bin")) ;Usual Integrations: Expanders + '("usiexp.bin")) ; Usual Integrations: Expanders (cons package/declarations - '("pardec.bin")) ;Declaration Parser + '("pardec.bin")) ; Declaration Parser (cons package/copy - '("copy.bin")) ;Copy Expressions + '("copy.bin")) ; Copy Expressions (cons package/free - '("free.bin")) ;Free Variable Analysis + '("free.bin")) ; Free Variable Analysis (cons package/change-type - '("chtype.bin")) ;Type interning + '("chtype.bin")) ; Type interning )))) (load-system! scode-optimizer/system true) (scode-optimizer/initialize!)) +#| + +See also the file SFSF.scm + +|# ;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT ) \ No newline at end of file diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm index 8bf2f284d..49d9daafa 100644 --- a/v7/src/sf/object.scm +++ b/v7/src/sf/object.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.1 1987/03/13 04:12:53 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.2 1988/03/22 17:37:47 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,8 @@ MIT in each case. |# ;;;; SCode Optimizer: Data Types (declare (usual-integrations)) +(declare (automagic-integrations)) +(declare (open-block-optimizations)) (let-syntax () @@ -120,7 +122,8 @@ MIT in each case. |# (declare (integrate-operator enumerand/enumeration enumerand/name enumerand/index enumeration/cardinality - enumeration/index->enumerand)) + enumeration/index->enumerand + enumeration/name->enumerand)) (define (enumerand/enumeration enumerand) (declare (integrate enumerand)) @@ -159,12 +162,12 @@ MIT in each case. |# ))) (define-type block random - (parent children safe? declarations bound-variables)) + (parent children safe? declarations bound-variables flags)) (define (block/make parent safe?) (let ((block (object/allocate block/enumerand parent '() safe? - (declarations/make-null) '()))) + (declarations/make-null) '() '()))) (if parent (block/set-children! parent (cons block (block/children parent)))) block)) @@ -180,15 +183,38 @@ MIT in each case. |# operations expression)) (define-simple-type variable random - (block name)) + (block name flags)) (define (variable/make&bind! block name) - (let ((variable (variable/make block name))) + (let ((variable (variable/make block name '()))) (block/set-bound-variables! block (cons variable (block/bound-variables block))) variable)) +(define (variable/flag? variable flag) + (memq flag (variable/flags variable))) + +(define (variable/set-flag! variable flag) + (declare (integrate variable/flag)) + (if (not (variable/flag? variable flag)) + (variable/set-flags! variable + (cons flag (variable/flags variable))))) + +(let-syntax ((define-flag + (macro (name tester setter) + `(BEGIN + (DEFINE (,tester VARIABLE) + (VARIABLE/FLAG? VARIABLE (QUOTE ,name))) + (DEFINE (,setter VARIABLE) + (VARIABLE/SET-FLAG! VARIABLE (QUOTE ,name))))))) + + (define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!) + (define-flag REFERENCED variable/referenced variable/reference!) + (define-flag INTEGRATED variable/integrated variable/integrated!) + (define-flag CAN-IGNORE variable/can-ignore? variable/can-ignore!) + ) + (define open-block/value-marker ;; This must be an interned object because we will fasdump it and ;; fasload it back in. @@ -245,7 +271,8 @@ MIT in each case. |# (define-simple-type delay expression (expression)) (define-simple-type disjunction expression (predicate alternative)) (define-simple-type in-package expression (environment quotation)) -(define-simple-type open-block expression (block variables values actions)) +(define-simple-type open-block expression (block variables values actions + optimized)) (define-simple-type procedure expression (block name required optional rest body)) (define-simple-type quotation expression (block expression)) diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm index 2f3a27d00..96a256f38 100644 --- a/v7/src/sf/pardec.scm +++ b/v7/src/sf/pardec.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.5 1987/07/08 04:42:52 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.6 1988/03/22 17:38:09 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,9 @@ MIT in each case. |# ;;;; SCode Optimizer: Parse Declarations (declare (usual-integrations)) +(declare (open-block-optimizations)) +(declare (automagic-integrations)) +(declare (eta-substitution)) (define (declarations/make-null) (declarations/make '() '() '())) @@ -218,6 +221,7 @@ MIT in each case. |# (define-declaration 'USUAL-INTEGRATIONS true (lambda (block table/cons table deletions) + block ; ignored (let ((finish (lambda (table operation names values) (transmit-values @@ -255,6 +259,7 @@ MIT in each case. |# (bind/values table/cons table 'INTEGRATE true names values))))) (define (parse-primitive-specification block specification) + block ; ignored (let ((finish (lambda (variable-name primitive-name) (return-2 variable-name @@ -269,18 +274,79 @@ MIT in each case. |# ((symbol? specification) (finish specification specification)) (else (error "Bad primitive specification" specification))))) +;;; Special declarations courtesy JRM + +;; I return the operations table unmodified, but bash on the +;; block. This actually works pretty well. + +;; One problem here with this multiple values hack is that +;; table is a multiple value -- yuck! + +(define-declaration 'AUTOMAGIC-INTEGRATIONS false + (lambda (block table/cons table names) + table/cons + names + (block/set-flags! block + (cons 'AUTOMAGIC-INTEGRATIONS (block/flags block))) + table)) + +(define-declaration 'ETA-SUBSTITUTION false + (lambda (block table/cons table names) + table/cons + names + (block/set-flags! block + (cons 'ETA-SUBSTITUTION (block/flags block))) + table)) + +(define-declaration 'OPEN-BLOCK-OPTIMIZATIONS false + (lambda (block table/cons table names) + table/cons + names + (block/set-flags! block + (cons 'OPEN-BLOCK-OPTIMIZATIONS (block/flags block))) + table)) + +(define-declaration 'NO-AUTOMAGIC-INTEGRATIONS false + (lambda (block table/cons table names) + table/cons + names + (block/set-flags! block + (cons 'NO-AUTOMAGIC-INTEGRATIONS (block/flags block))) + table)) + +(define-declaration 'NO-ETA-SUBSTITUTION false + (lambda (block table/cons table names) + table/cons + names + (block/set-flags! block + (cons 'NO-ETA-SUBSTITUTION (block/flags block))) + table)) + +(define-declaration 'NO-OPEN-BLOCK-OPTIMIZATIONS false + (lambda (block table/cons table names) + table/cons + names + (block/set-flags! block + (cons 'NO-OPEN-BLOCK-OPTIMIZATIONS + (block/flags block))) + table)) + + ;;;; Integration of User Code (define-declaration 'INTEGRATE false (lambda (block table/cons table names) + block ; ignored (bind/no-values table/cons table 'INTEGRATE true names))) (define-declaration 'INTEGRATE-OPERATOR false (lambda (block table/cons table names) + block ; ignored (bind/no-values table/cons table 'INTEGRATE-OPERATOR true names))) (define-declaration 'INTEGRATE-EXTERNAL true (lambda (block table/cons table specifications) + block ; ignored (accumulate (lambda (extern table) (bind/values table/cons table (vector-ref extern 1) false @@ -315,6 +381,7 @@ MIT in each case. |# (if info (transmit-values info (lambda (value uninterned) + uninterned ; ignored (finish value))) (variable/final-value variable environment finish if-not)))))) @@ -326,6 +393,7 @@ MIT in each case. |# (define-declaration 'EXPAND-OPERATOR true (lambda (block table/cons table expanders) + block ; ignored (bind/general table/cons table false 'EXPAND false (map car expanders) (map (lambda (expander) diff --git a/v7/src/sf/pthmap.scm b/v7/src/sf/pthmap.scm index c09edb7d2..d070c50b6 100644 --- a/v7/src/sf/pthmap.scm +++ b/v7/src/sf/pthmap.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pthmap.scm,v 1.1 1987/05/09 23:22:21 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pthmap.scm,v 1.2 1988/03/22 17:38:21 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,9 @@ MIT in each case. |# ;;;; Pathname Maps (declare (usual-integrations)) +(declare (automagic-integrations)) +(declare (open-block-optimizations)) +(declare (eta-substitution)) (define pathname-map/make) (define pathname-map?) @@ -62,6 +65,8 @@ MIT in each case. |# (write-string "PATHNAME-MAP ") (write (hash map)))))) +(declare (integrate-operator node/make)) + (define (node/make) (cons unbound-value '())) @@ -84,6 +89,8 @@ MIT in each case. |# (cons-if (pathname-version pathname) '())))))) +(declare (integrate-operator cons-if)) + (define (cons-if item rest) (if item (cons item rest) diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm index c3c01584e..98d98798b 100644 --- a/v7/src/sf/subst.scm +++ b/v7/src/sf/subst.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.6 1987/07/08 04:43:11 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.7 1988/03/22 17:39:01 jrm Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,35 +35,49 @@ MIT in each case. |# ;;;; SCode Optimizer: Beta Substitution (declare (usual-integrations)) +(declare (eta-substitution)) +(declare (open-block-optimizations)) + +(using-syntax sf-syntax-table + (define *top-level-block*) (define (integrate/get-top-level-block) *top-level-block*) +;; Block names are added to this list so +;; warnings can be more descriptive. + +(define *current-block-names*) + (define (integrate/top-level block expression) - (fluid-let ((*top-level-block* block)) - (let ((operations (operations/bind-block (operations/make) block)) - (environment (environment/make))) - (if (open-block? expression) - (transmit-values - (environment/recursive-bind operations environment - (open-block/variables expression) - (open-block/values expression)) - (lambda (environment values) - (return-3 operations - environment - (quotation/make block - (integrate/open-block operations - environment - expression - values))))) - (return-3 operations - environment - (quotation/make block - (integrate/expression operations - environment - expression))))))) + (fluid-let ((*top-level-block* block) + (*current-block-names* '())) + (process-block-flags (block/flags block) + (lambda () + (let ((operations (operations/bind-block (operations/make) block)) + (environment (environment/make))) + (if (open-block? expression) + (transmit-values + (environment/recursive-bind operations environment + (open-block/variables expression) + (open-block/values expression)) + (lambda (environment values) + (return-3 operations + environment + (quotation/make block + (integrate/open-block operations + environment + expression + values))))) + (return-3 operations + environment + (quotation/make block + (integrate/expression operations + environment + expression))) + )))))) (define (operations/bind-block operations block) (let ((declarations (block/declarations block))) @@ -92,53 +106,123 @@ MIT in each case. |# ;;;; Lookup +(define *eager-integration-switch #t) + (define-method/integrate 'REFERENCE (lambda (operations environment expression) - (operations/lookup operations (reference/variable expression) - (lambda (operation info) - (case operation - ((INTEGRATE-OPERATOR EXPAND) expression) - ((INTEGRATE) - (integrate/name expression info environment - identity-procedure - (lambda () expression))) - (else (error "Unknown operation" operation)))) - (lambda () expression)))) + (let ((variable (reference/variable expression))) + (operations/lookup operations variable + (lambda (operation info) + (case operation + ((INTEGRATE-OPERATOR EXPAND) + (variable/reference! variable) + expression) + ((INTEGRATE) + (integrate/name expression info environment + (lambda (new-expression) + (variable/integrated! variable) + new-expression) + (lambda () + (variable/reference! variable) + expression))) + (else (error "Unknown operation" operation)))) + (lambda () + (if *eager-integration-switch + (integrate/name-if-safe expression environment + (lambda (new-expression) + (variable/integrated! variable) + new-expression) + (lambda () + (variable/reference! variable) + expression)) + (begin (variable/reference! variable) + expression))))))) + +(define (integrate/name-if-safe reference environment if-win if-fail) + (let ((variable (reference/variable reference))) + (if (or (variable/side-effected variable) + (not (block/safe? (variable/block variable)))) + (if-fail) + (let ((finish + (lambda (value) + (if (constant-value? value) + (if-win + (copy/expression (reference/block reference) value + #f)) + (if-fail))))) + (environment/lookup environment variable + (lambda (value) + (if (delayed-integration? value) + (if (delayed-integration/in-progress? value) + (if-fail) + (finish (delayed-integration/force value))) + (finish value))) + (lambda () (if-fail)) + (lambda () (if-fail))))))) + +(define (constant-value? value) + (or (constant? value) + (and (reference? value) + (not (variable/side-effected (reference/variable value))) + (block/safe? (variable/block (reference/variable value)))))) (define (integrate/reference-operator operations environment operator operands) - (let ((dont-integrate - (lambda () - (combination/make operator operands)))) - (operations/lookup operations (reference/variable operator) - (lambda (operation info) - (case operation - ((#F) (dont-integrate)) - ((INTEGRATE INTEGRATE-OPERATOR) - (integrate/name operator info environment - (lambda (operator) - (integrate/combination operations environment operator - operands)) - dont-integrate)) - ((EXPAND) - (info operands - (lambda (new-expression) - (integrate/expression operations environment new-expression)) - dont-integrate - (reference/block operator))) - (else (error "Unknown operation" operation)))) - dont-integrate))) + (let ((variable (reference/variable operator))) + (let ((dont-integrate + (lambda () + (variable/reference! variable) + (combination/optimizing-make operator operands))) + (mark-integrated! + (lambda () + (variable/integrated! variable)))) + (operations/lookup operations variable + (lambda (operation info) + (case operation + ((#F) (dont-integrate)) + ((INTEGRATE INTEGRATE-OPERATOR) + (integrate/name operator info environment + (lambda (operator) + (mark-integrated!) + (integrate/combination operations environment + operator + operands)) + dont-integrate)) + ((EXPAND) + (info operands + (lambda (new-expression) + (mark-integrated!) + (integrate/expression operations environment + new-expression)) + dont-integrate + (reference/block operator))) + (else (error "Unknown operation" operation)))) + (lambda () + (if *eager-integration-switch + (integrate/name-if-safe operator environment + (lambda (operator) + (mark-integrated!) + (integrate/combination operations + environment + operator + operands)) + dont-integrate) + (dont-integrate))))))) (define-method/integrate 'ASSIGNMENT (lambda (operations environment assignment) (let ((variable (assignment/variable assignment))) (operations/lookup operations variable (lambda (operation info) + info (case operation ((INTEGRATE INTEGRATE-OPERATOR EXPAND) (warn "Attempt to assign integrated name" (variable/name variable))) (else (error "Unknown operation" operation)))) (lambda () 'DONE)) + ;; The value of an assignment is the old value + ;; of the variable, hence, it is refernced. + (variable/reference! variable) (assignment/make (assignment/block assignment) variable (integrate/expression operations @@ -151,43 +235,167 @@ MIT in each case. |# (lambda (operations environment expression) (let ((operations (operations/bind-block operations (open-block/block expression)))) - (transmit-values - (environment/recursive-bind operations - environment - (open-block/variables expression) - (open-block/values expression)) - (lambda (environment values) - (integrate/open-block operations - environment - expression - values)))))) + (process-block-flags (block/flags (open-block/block expression)) + (lambda () + (transmit-values + (environment/recursive-bind operations + environment + (open-block/variables expression) + (open-block/values expression)) + (lambda (environment values) + (integrate/open-block operations + environment + expression + values)))))))) + +(define (process-block-flags flags continuation) + (if (null? flags) + (continuation) + (let ((this-flag (car flags))) + (case this-flag + ((AUTOMAGIC-INTEGRATIONS) + (fluid-let ((*eager-integration-switch #T)) + (process-block-flags (cdr flags) continuation))) + ((NO-AUTOMAGIC-INTEGRATIONS) + (fluid-let ((*eager-integration-switch #F)) + (process-block-flags (cdr flags) continuation))) + ((ETA-SUBSTITUTION) + (fluid-let ((*eta-substitution-switch #T)) + (process-block-flags (cdr flags) continuation))) + ((NO-ETA-SUBSTITUTION) + (fluid-let ((*eta-substitution-switch #F)) + (process-block-flags (cdr flags) continuation))) + ((OPEN-BLOCK-OPTIMIZATIONS) + (fluid-let ((*block-optimizing-switch #T)) + (process-block-flags (cdr flags) continuation))) + ((NO-OPEN-BLOCK-OPTIMIZATIONS) + (fluid-let ((*block-optimizing-switch #F)) + (process-block-flags (cdr flags) continuation))) + (else (error "Bad flag")))))) (define (integrate/open-block operations environment expression values) - (open-block/make (open-block/block expression) - (open-block/variables expression) - values - (map (lambda (action) - (if (eq? action open-block/value-marker) - action - (integrate/expression operations - environment - action))) - (open-block/actions expression)))) + (let ((actions (map (lambda (action) + (if (eq? action open-block/value-marker) + action + (integrate/expression operations environment action))) + (open-block/actions expression))) + (vars (open-block/variables expression))) + ;; Complain about unreferenced variables. + ;; If the block is unsafe, then it is likely that + ;; there will be a lot of them on purpose (top level or + ;; the-environment) so no complaining. + (if (block/safe? (open-block/block expression)) + (for-each (lambda (var) + (if (and (not (variable/integrated var)) + (not (variable/referenced var)) + (not (variable/can-ignore? var))) + (warn "Open block variable bound and unreferenced:" + (variable/name var)))) + vars)) + (if (open-block/optimized expression) + (open-block/make (open-block/block expression) + vars + values + actions + #t) + (open-block/optimizing-make (open-block/block expression) + vars + values + actions + operations + environment)))) + +;; Cannot optimize (lambda () (bar)) => bar (eta substitution) +;; because BAR may be a procedure with different +;; arity than the lambda + +#| You can get some weird stuff with this + +(define (foo x) + (define (loop1) (loop2)) + (define (loop2) (loop3)) + (define (loop3) (loop1)) + (bar x)) + +will optimize into + +(define (foo x) + (define loop1 loop3) + (define loop2 loop3) + (define loop3 loop3) + (bar x)) + +and if you have automagic integrations on, this won't finish +optimizing. Well, you told the machine to loop forever, and it +determines that it can do this at compile time, so you get what +you ask for. + +|# + + +(define *eta-substitution-switch #f) (define (integrate/procedure operations environment procedure) - (let ((block (procedure/block procedure))) - (procedure/make block - (procedure/name procedure) - (procedure/required procedure) - (procedure/optional procedure) - (procedure/rest procedure) - (integrate/expression (operations/bind-block operations - block) - environment - (procedure/body procedure))))) + (let ((block (procedure/block procedure)) + (required (procedure/required procedure)) + (optional (procedure/optional procedure)) + (rest (procedure/rest procedure))) + (fluid-let ((*current-block-names* + (cons (procedure/name procedure) + *current-block-names*))) + (process-block-flags (block/flags block) + (lambda () + (let ((body + (integrate/expression (operations/bind-block operations block) + environment + (procedure/body procedure)))) + ;; Possibly complain about variables bound and not + ;; referenced. + (if (block/safe? block) + (for-each (lambda (variable) + (if (and (not (variable/referenced variable)) + (not (variable/integrated variable)) + (not (variable/can-ignore? variable))) + (warn "Procedure variable bound and unreferenced:" + (variable/name variable) + *current-block-names*))) + (if rest + (append required optional (list rest)) + (append required optional)))) + (if (and *eta-substitution-switch + (combination? body) + (null? optional) + (null? rest) + (let ((operands (combination/operands body))) + (match-up? operands required)) + (set/empty? + (set/intersection + (list->set variable? eq? required) + (free/expression (combination/operator body))))) + (combination/operator body) + (procedure/make block + (procedure/name procedure) + required + optional + rest + body)))))))) + +(define (match-up? operands required) + (cond ((null? operands) (null? required)) + ((null? required) #f) + (else (let ((this-operand (car operands)) + (this-required (car required))) + (and (reference? this-operand) + (eq? (reference/variable this-operand) this-required) + (match-up? (cdr operands) (cdr required))))))) + (define-method/integrate 'PROCEDURE - integrate/procedure) + (lambda (operations environment procedure) + (integrate/procedure operations + (simulate-unknown-application environment procedure) + procedure))) + (define-method/integrate 'COMBINATION (lambda (operations environment combination) @@ -246,40 +454,96 @@ MIT in each case. |# (define-method/integrate 'CONSTANT (lambda (operations environment expression) + operations + environment expression)) (define-method/integrate 'THE-ENVIRONMENT (lambda (operations environment expression) + operations + environment expression)) (define-method/integrate 'QUOTATION (lambda (operations environment expression) + operations + environment (integrate/quotation expression))) +;; Optimize (if () a b) => b; (if #t a b) => a + (define-method/integrate 'CONDITIONAL (lambda (operations environment expression) - (conditional/make - (integrate/expression operations environment - (conditional/predicate expression)) - (integrate/expression operations environment - (conditional/consequent expression)) - (integrate/expression operations environment - (conditional/alternative expression))))) + (let ((predicate (integrate/expression + operations environment + (conditional/predicate expression))) + (consequent (integrate/expression + operations environment + (conditional/consequent expression))) + (alternative (integrate/expression + operations environment + (conditional/alternative expression)))) + (if (constant? predicate) + (if (null? (constant/value predicate)) + alternative + consequent) + (conditional/make predicate consequent alternative))))) + +;; Optimize (or () a) => a; (or #t a) => #t (define-method/integrate 'DISJUNCTION (lambda (operations environment expression) - (disjunction/make - (integrate/expression operations environment - (disjunction/predicate expression)) - (integrate/expression operations environment - (disjunction/alternative expression))))) + (let ((predicate (integrate/expression operations environment + (disjunction/predicate expression))) + (alternative (integrate/expression + operations environment + (disjunction/alternative expression)))) + (if (constant? predicate) + (if (null? (constant/value predicate)) + alternative + predicate) + (disjunction/make predicate alternative))))) + +;; Optimize (begin (foo)) => (foo) +;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar)) + (define-method/integrate 'SEQUENCE (lambda (operations environment expression) - (sequence/make + (sequence/optimizing-make (integrate/expressions operations environment (sequence/actions expression))))) +(define (sequence/optimizing-make expression-list) + (define (remove-non-side-effecting-expressions expression-list) + (cond ((null? (cdr expression-list)) expression-list) + ;; This clause lets you ignore a variable by mentioning it + ;; in a sequence. + ((reference? (car expression-list)) + (variable/can-ignore! (reference/variable (car expression-list))) + (remove-non-side-effecting-expressions (cdr expression-list))) + ((non-side-effecting-in-sequence? (car expression-list)) + (remove-non-side-effecting-expressions (cdr expression-list))) + (else (cons (car expression-list) + (remove-non-side-effecting-expressions + (cdr expression-list)))))) + (let ((pruned-elist (remove-non-side-effecting-expressions expression-list))) + (if (null? (cdr pruned-elist)) + (car pruned-elist) + (sequence/make pruned-elist)))) + +;; To do this right, we really need a compiler that knows +;; about call for effect, call for predicate, etc. + +(define (non-side-effecting-in-sequence? expression) + (or (constant? expression) + (quotation? expression) + (delay? expression) + (procedure? expression) + ;; access if the environment is okay to not + ;; eval. + )) + (define-method/integrate 'ACCESS (lambda (operations environment expression) (let ((environment* (access/environment expression)) @@ -327,6 +591,8 @@ MIT in each case. |# (transmit-values (integrate/top-level (quotation/block quotation) (quotation/expression quotation)) (lambda (operations environment expression) + operations + environment expression))) ;;;; Environment @@ -363,6 +629,7 @@ MIT in each case. |# (if-not) (finish (delayed-integration/force value) '())) (finish value '()))) + if-not if-not))))) (define (variable/final-value variable environment if-value if-not) @@ -373,10 +640,36 @@ MIT in each case. |# (error "Unfinished integration" value) (if-value (delayed-integration/force value))) (if-value value))) + (lambda () + (if-not)) (lambda () (warn "Unable to integrate" (variable/name variable)) (if-not)))) +(define *unknown-value "Unknown Value") + +(define (simulate-unknown-application environment procedure) + (define (bind-required environment required) + (if (null? required) + (bind-optional environment (procedure/optional procedure)) + (bind-required + (environment/bind environment (car required) *unknown-value) + (cdr required)))) + + (define (bind-optional environment optional) + (if (null? optional) + (bind-rest environment (procedure/rest procedure)) + (bind-optional + (environment/bind environment (car optional) *unknown-value) + (cdr optional)))) + + (define (bind-rest environment rest) + (if (null? rest) + environment + (environment/bind environment rest *unknown-value))) + + (bind-required environment (procedure/required procedure))) + (define (simulate-application environment procedure operands) (define (match-required environment required operands) @@ -421,16 +714,22 @@ MIT in each case. |# (define (environment/make) '()) +(declare (integrate environment/bind environment/bind-multiple)) + (define (environment/bind environment variable value) + (declare (integrate environment variable value)) (cons (cons variable value) environment)) (define (environment/bind-multiple environment variables values) + (declare (integrate environment variables values)) (map* environment cons variables values)) -(define (environment/lookup environment variable if-found if-not) +(define (environment/lookup environment variable if-found if-unknown if-not) (let ((association (assq variable environment))) (if association - (if-found (cdr association)) + (if (eq? (cdr association) *unknown-value) + (if-unknown) + (if-found (cdr association))) (if-not)))) (define (delayed-integration/in-progress? delayed-integration) @@ -465,98 +764,553 @@ MIT in each case. |# (define combination/optimizing-make) (let () +#| +Simple LET-like combination. Delete any unreferenced +parameters. If no parameters remain, delete the +combination and lambda. Values bound to the unreferenced +parameters are pulled out of the combination. But integrated +forms are simply removed. + +(define (foo a) + (let ((a (+ a 3)) + (b (bar a)) + (c (baz a))) + (declare (integrate c)) + (+ c a))) + + || + \/ + +(define (foo a) + (bar a) + (let ((a (+ a 3))) + (+ (baz a) a))) + +|# + +(define (foldable-constant? thing) + (constant? thing)) + +(define (foldable-constants? list) + (or (null? list) + (and (foldable-constant? (car list)) + (foldable-constants? (cdr list))))) + +(define (foldable-constant-value thing) + (cond ((constant? thing) (constant/value thing)) + (else (error "can't happen")))) + +(define *foldable-primitive-procedures + (map make-primitive-procedure + '(PRIMITIVE-TYPE PRIMITIVE-TYPE? + NOT EQ? NULL? PAIR? ZERO? POSITIVE? NEGATIVE? + &= &< &> &+ &- &* &/ INTEGER-DIVIDE 1+ -1+ + TRUNCATE ROUND FLOOR CEILING + SQRT EXP LOG SIN COS &ATAN))) +(define (foldable-operator? operator) + (and (constant? operator) + (primitive-procedure? (constant/value operator)) + (memq (constant/value operator) *foldable-primitive-procedures))) + +;;; deal with (let () (define ...)) +;;; deal with (let ((x 7)) (let ((y 4)) ...)) => (let ((x 7) (y 4)) ...) +;;; Actually, we really don't want to hack with these for various +;;; reasons + (set! combination/optimizing-make (lambda (operator operands) - (if (and (procedure? operator) - (null? (procedure/optional operator)) - (not (procedure/rest operator)) - (block/safe? (procedure/block operator)) - (not (open-block? (procedure/body operator)))) - ;; Simple LET-like combination. Delete any unreferenced - ;; parameters. If no parameters remain, delete the - ;; combination and lambda. - (transmit-values ((delete-integrated-parameters - (declarations/integrated-variables - (block/declarations (procedure/block operator)))) - (procedure/required operator) - operands) - (lambda (required operands) - (if (null? required) - (procedure/body operator) - (combination/make (procedure/make (procedure/block operator) - (procedure/name operator) - required - '() - false - (procedure/body operator)) - operands)))) - (combination/make operator operands)))) - -(define (delete-integrated-parameters integrated) - (define (loop parameters operands) - (if (null? parameters) - (return-2 '() operands) - (let ((rest (loop (cdr parameters) (cdr operands)))) - (if (memq (car parameters) integrated) - rest - (transmit-values rest - (lambda (parameters* operands*) - (return-2 (cons (car parameters) parameters*) - (cons (car operands) operands*)))))))) - loop) + (cond ((and (foldable-operator? operator) + (foldable-constants? operands)) + ;; fold constants + (constant/make (apply (constant/value operator) + (map foldable-constant-value operands)))) + ((and (procedure? operator) + (null? (procedure/optional operator)) + (not (procedure/rest operator)) + (block/safe? (procedure/block operator)) + ) + (delete-unreferenced-parameters + (procedure/required operator) + (procedure/body operator) + operands + (lambda (required referenced-operands unreferenced-operands) + (let ((form + (if (and (null? required) + ;; need to avoid things like this + ;; (foo bar (let () (define (baz) ..) ..)) + ;; optimizing into + ;; (foo bar (define (baz) ..) ..) + (not (open-block? (procedure/body operator)))) + (procedure/body operator) + (combination/make + (procedure/make + (procedure/block operator) + (procedure/name operator) + required + '() + false + (procedure/body operator)) + referenced-operands)))) + (if (null? unreferenced-operands) + form + (sequence/optimizing-make + (append unreferenced-operands (list form)))))))) + (else + (combination/make operator operands))))) + +(define (delete-unreferenced-parameters parameters body operands receiver) + (let ((free-in-body (free/expression body))) + (let loop ((parameters parameters) + (operands operands) + (required-parameters '()) + (referenced-operands '()) + (unreferenced-operands '())) + (cond ((null? parameters) + (if (null? operands) + (receiver required-parameters referenced-operands + unreferenced-operands) + (error "Argument mismatch" (block/bound-variables block)))) + ((null? operands) (error "Argument mismatch" + (block/bound-variables block))) + (else (let ((this-parameter (car parameters)) + (this-operand (car operands))) + (cond ((set/member? free-in-body this-parameter) + (loop (cdr parameters) + (cdr operands) + (cons this-parameter required-parameters) + (cons this-operand referenced-operands) + unreferenced-operands)) + ((variable/integrated this-parameter) + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + unreferenced-operands)) + (else + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + (cons this-operand unreferenced-operands)))))))) + )) + ;;; end COMBINATION/OPTIMIZING-MAKE ) -#| This is too much of a pain to do now. Maybe later. -(define procedure/optimizing-make) +(define *block-optimizing-switch #f) + +;; This is overly hairy, but if it works, no one need know. +;; What we do is this: +;; 1 Make a directed graph of the dependencies in an open +;; block. +;; 2 Identify the circular dependencies and place them in +;; a open block. +;; 3 Identify the bindings that can be made in parallel and +;; make LET type statements. +;; 4 This deletes unused bindings in an open block and +;; compartmentalizes the environment. +;; 5 Re-optimize the code in the body. This can help if the +;; eta-substitution-switch is on. + +(define open-block/optimizing-make) + (let () -(set! procedure/optimizing-make - (lambda (block name required optional rest auxiliary body) - (if (and (not (null? auxiliary)) - optimize-open-blocks? - (block/safe? block)) - (let ((used - (used-auxiliaries (list-transform-positive auxiliary - variable-value) - (free/expression body)))) - (procedure/make block name required optional rest used - (delete-unused-definitions used body))) - (procedure/make block name required optional rest auxiliary body)))) - -(define (delete-unused-definitions used body) - ???) - -;;; A non-obvious program: (1) Collect all of the free references to -;;; the block's bound variables which occur in the body of the block. -;;; (2) Examine each of the values associated with that set of free -;;; references, and add any new free references to the collection. -;;; (3) Continue looping until no more free references are added. - -(define (used-auxiliaries auxiliary initial-used) - (let ((used (eq?-set/intersection auxiliary initial-used))) - (if (null? used) +(set! open-block/optimizing-make + (named-lambda (open-block/optimizing-make block vars values actions + operations environment) + (if (and *block-optimizing-switch + (block/safe? block)) + (let ((table:var->vals (associate-vars-and-vals vars values)) + (bound-variables (varlist->varset vars))) + (let ((table:vals->free + (get-free-vars-in-bindings bound-variables values)) + (body-free (get-body-free-vars bound-variables actions))) +; (write-string "Free vars in body") +; (display (map variable/name body-free)) + (let ((graph (build-graph vars + table:var->vals + table:vals->free + body-free))) + (collapse-circularities! graph) + ;(print-graph graph) + (label-node-depth! graph) + (let ((template (linearize graph))) + ; (print-template template) + (integrate/expression + operations + environment (build-new-code template + (block/parent block) + table:var->vals actions)))))) + (open-block/make block vars values actions #t)))) + +(define (print-template template) + (if (null? template) + '() + (let ((this (car template))) + (newline) + (display (car this)) + (display (map variable/name (cdr this))) + (print-template (cdr template))))) + +(define (associate-vars-and-vals vars vals) + (let ((table (make-generic-eq?-table))) + (define (fill-table vars vals) + (cond ((null? vars) (if (null? vals) '() (error "Mismatch"))) + ((null? vals) (error "Mismatch")) + (else (table-put! table (car vars) (car vals)) + (fill-table (cdr vars) (cdr vals))))) + (fill-table vars vals) + table)) + +(declare (integrate varlist->varset nodelist->nodeset + empty-nodeset singleton-nodeset + empty-varset singleton-varset)) + +(define (varlist->varset list) + (declare (integrate list)) + (list->set variable? eq? list)) + +(define (nodelist->nodeset list) + (declare (integrate list)) + (list->set node? eq? list)) + +(define (empty-nodeset) + (empty-set node? eq?)) + +(define (singleton-nodeset node) + (declare (integrate node)) + (singleton-set node? eq? node)) + +(define (empty-varset) + (declare (integrate node)) + (empty-set variable? eq?)) + +(define (singleton-varset variable) + (declare (integrate variable)) + (singleton-set variable? eq? variable)) + +(define (get-free-vars-in-bindings bound-variables vals) + ;; find variables in bindings that are scoped to these + ;; bound variables + (let ((table (make-generic-eq?-table))) + (define (kernel val) + (let ((free-variables (free/expression val))) + (table-put! table val + (set/intersection bound-variables free-variables)))) + (for-each kernel vals) + table)) + +(define (get-body-free-vars bound-variables actions) + (let ((body-forms (get-body actions))) + (let loop ((body-forms body-forms) + (free (empty-varset))) + (if (null? body-forms) + free + (loop (cdr body-forms) + (set/union free + (set/intersection bound-variables + (free/expression + (car body-forms))))))))) + +(define (get-body actions) + (cond ((null? actions) '()) + ((eq? (car actions) open-block/value-marker) (get-body (cdr actions))) + (else (cons (car actions) (get-body (cdr actions)))))) + +;;; Graph structure for figuring out dependencies in a LETREC + +(define-unsafe-named-structure node type vars needs needed-by depth) + +((access add-unparser-special-object! unparser-package) + *node-tag + (lambda (node) + (unparse-with-brackets + (lambda () + (write-string "Node") + (write (hash node)))))) + +(declare (integrate make-base-node variable->node make-letrec-node)) + +(define (make-base-node) + (%make-node 'BASE + (empty-varset) + (empty-nodeset) + (empty-nodeset) + #f)) + +(define (variable->node variable) + (declare (integrate variable)) + (%make-node 'SETUP + (singleton-varset variable) + (empty-nodeset) + (empty-nodeset) + #F)) + +(define (make-letrec-node variable-set) + (declare (integrate variable-set)) + (%make-node 'LETREC + variable-set + (empty-nodeset) + (empty-nodeset) + #f)) + +(declare (integrate add-node-need! remove-node-need! + add-node-needed-by! remove-node-needed-by!)) + + +(define (add-node-need! needer what-i-need) + (declare (integrate what-i-need)) + (%set-node-needs! needer (set/adjoin (%node-needs needer) what-i-need))) + +(define (remove-node-need! needer what-i-no-longer-need) + (declare (integrate what-i-no-longer-need)) + (%set-node-needs! needer + (set/remove (%node-needs needer) what-i-no-longer-need))) + +(define (add-node-needed-by! needee what-needs-me) + (declare (integrate what-needs-me)) + (%set-node-needed-by! needee + (set/adjoin (%node-needed-by needee) what-needs-me))) + +(define (remove-node-needed-by! needee what-needs-me) + (declare (integrate what-needs-me)) + (%set-node-needed-by! needee + (set/remove (%node-needed-by needee) what-needs-me))) + +(define (build-graph vars table:var->vals table:vals->free body-free) + (let ((table:variable->node (make-generic-eq?-table))) + + (define (kernel variable) + (let ((node (variable->node variable))) + (table-put! table:variable->node variable node))) + + (for-each kernel vars) + + (link-nodes! body-free table:var->vals table:vals->free vars + table:variable->node))) + +(declare (integrate link-2-nodes!)) + +(define (link-2-nodes! from-node to-node) + (add-node-need! from-node to-node) + (add-node-needed-by! to-node from-node)) + +(define (unlink-node! node) + (set/for-each (lambda (needer) + (remove-node-needed-by! needer node)) + (%node-needs node)) + (set/for-each (lambda (needee) + (remove-node-need! needee node)) + (%node-needed-by node)) + (%set-node-type! node 'UNLINKED)) + +(declare (integrate unlink-nodes!)) + +(define (unlink-nodes! nodelist) + (for-each unlink-node! nodelist)) + +(define (link-nodes! body-free + table:var->vals table:vals->free variables table:var->node) + + (define (kernel variable) + (table-get table:var->node variable + (lambda (node) + (table-get-chain variable + (lambda (free-vars) + (set/for-each + (lambda (needed-var) + (table-get table:var->node needed-var + (lambda (needed-node) + (link-2-nodes! node needed-node)) + (lambda () + (error "Broken analysis: can't get node")))) + free-vars)) + (lambda () (error "Broken analysis: can't get free variable info")) + table:var->vals table:vals->free)) + (lambda () (error "Broken analysis: no node for variable")))) + + (for-each kernel variables) + + (let ((base-node (make-base-node))) + (set/for-each + (lambda (needed-var) + (table-get table:var->node needed-var + (lambda (needed-node) + (link-2-nodes! base-node needed-node)) + (lambda () (error "Broken analysis: free var")))) + body-free) + base-node)) + +(define (collapse-circularities! graph) + ;; Search for a circularity: if found, collapse it, and repeat + ;; until none are found. + (define (loop) + (find-circularity graph + (lambda (nodelist) + (collapse-nodelist! nodelist) + (loop)) + (lambda () graph))) + (loop)) + +(define (find-circularity graph if-found if-not) + ;; Walk the tree keeping track of nodes visited + ;; If a node is encountered more than once, there is + ;; a circularitiy. NODES-VISITED is a list kept in + ;; base node first order. If a node is found on the + ;; list, the tail of the list is the nodes in the + ;; circularity. + + (define (fc this-node nodes-visited if-found if-not) + (if (null? this-node) + (if-not) + (let ((circularity (memq this-node nodes-visited))) + (if circularity + (if-found circularity) + ;; Add this node to the visited list, and loop + ;; over the needs of this node. + (let ((new-visited (append nodes-visited (list this-node)))) + (let loop ((needs (set->list (%node-needs this-node)))) + (if (null? needs) + (if-not) + (fc (car needs) new-visited if-found + (lambda () (loop (cdr needs))))))))))) + + (fc graph '() if-found if-not)) + +(define (collapse-nodelist! nodelist) + ;; Replace the nodes in the nodelist with a single node that + ;; has all the variables in it. This node will become a LETREC + ;; form. + + ;; Error check: make sure graph is consistant. + (for-each (lambda (node) (if (eq? (%node-type node) 'UNLINKED) + (error "node not linked"))) + nodelist) + + (let ((nodeset (nodelist->nodeset nodelist))) + (let ((varset (apply set/union* (map %node-vars nodelist))) + (needs-set (set/difference + (apply set/union* (map %node-needs nodelist)) + nodeset)) + (needed-by (set/difference + (apply set/union* (map %node-needed-by nodelist)) + nodeset))) + + (let ((letrec-node (make-letrec-node varset))) + (set/for-each (lambda (need) (link-2-nodes! letrec-node need)) needs-set) + (set/for-each + (lambda (needer) (link-2-nodes! needer letrec-node)) needed-by) + ;; now delete nodes in nodelist + (unlink-nodes! nodelist))))) + +(define (label-node-depth! graph) + (define (label-nodes! nodeset depth) + (if (set/empty? nodeset) '() - (let loop ((previous-used used) (new-used used)) - (for-each (lambda (value) - (for-each (lambda (variable) - (if (and (memq variable auxiliary) - (not (memq variable used))) - (set! used (cons variable used)))) - (free/expression value))) - (map variable/value new-used)) - (let ((diffs - (let note-diffs ((used used)) - (if (eq? used previous-used) - '() - (cons (cdar used) - (note-diffs (cdr used))))))) - (if (null? diffs) - used - (loop used diffs))))))) - -;;; end PROCEDURE/OPTIMIZING-MAKE -) -|# \ No newline at end of file + (begin + (set/for-each (lambda (node) (%set-node-depth! node depth)) nodeset) + (label-nodes! + (apply set/union* (map %node-needs (set->list nodeset))) + (1+ depth))))) + (label-nodes! (singleton-nodeset graph) 0)) + +(define (print-graph node) + (if (null? node) + '() + (begin + (newline) + (display (%node-depth node)) + (display (%node-type node)) + (set/for-each (lambda (variable) + (display " ") + (display (variable/name variable))) + (%node-vars node)) + (set/for-each print-graph (%node-needs node))))) + +(define (collapse-parallel-nodelist depth nodeset) + (if (set/empty? nodeset) + '() + (let loop ((nodestream (set->list nodeset)) + (let-children (empty-varset)) + (letrec-children (empty-varset)) + (children (empty-nodeset))) + (if (null? nodestream) + (let ((outer-contour + (collapse-parallel-nodelist (1+ depth) children))) + (append (if (set/empty? let-children) + '() + (list (cons 'LET (set->list let-children)))) + (if (set/empty? letrec-children) + '() + (list (cons 'LETREC (set->list letrec-children)))) + outer-contour)) + (let ((this-node (car nodestream))) + (if (= (%node-depth this-node) (1+ depth)) + (if (eq? (%node-type this-node) 'LETREC) + (loop (cdr nodestream) + let-children + (set/union (%node-vars this-node) letrec-children) + (set/union (%node-needs this-node) children)) + (loop (cdr nodestream) + (set/union (%node-vars this-node) let-children) + letrec-children + (set/union (%node-needs this-node) children))) + ;; deeper nodes will be picked up later + (loop (cdr nodestream) + let-children + letrec-children + children))))))) + +(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)))) + (let loop ((template template) + (block parent) + (code body)) + (if (null? template) + code + (let ((this (car template))) + (let ((this-type (car this)) + (this-vars (cdr this))) + (let ((this-vals + (map (lambda (var) + (table-get vars->vals var + (lambda (val) val) + (lambda () (error "broken")))) + this-vars))) + + (if (eq? this-type 'LET) + (let ((block (block/make block true))) + (block/set-bound-variables! block this-vars) + (loop (cdr template) + block + (combination/optimizing-make + (procedure/make + block + lambda-tag:let + this-vars + '() + false + code) + this-vals))) + (let ((block (block/make block true))) + (block/set-bound-variables! block this-vars) + (loop (cdr template) + block + (open-block/make + block this-vars this-vals + (append (make-list + (length this-vals) + open-block/value-marker) + (list code)) + #t))))))))))) + +) ;; End of OPEN-BLOCK/OPTIMIZING-MAKE + + +) ;; End of USING-SYNTAX SF-SYNTAX-TABLE \ No newline at end of file diff --git a/v7/src/sf/tables.scm b/v7/src/sf/tables.scm index 50de2dbbd..dc499f378 100644 --- a/v7/src/sf/tables.scm +++ b/v7/src/sf/tables.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.1 1987/03/13 04:14:10 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.2 1988/03/22 17:40:04 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,7 @@ MIT in each case. |# ;;;; SCode Optimizer: Tables (declare (usual-integrations)) +(declare (automagic-integrations)) ;;;; Operations diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index b894c22e4..58c8ae889 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.5 1988/02/28 22:59:02 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.6 1988/03/22 17:40:18 jrm Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -35,6 +35,8 @@ MIT in each case. |# ;;;; SCode Optimizer: Top Level (declare (usual-integrations)) +(declare (automagic-integrations)) +(declare (open-block-optimizations)) ;;;; User Interface @@ -259,6 +261,7 @@ Currently only the 68000 implementation needs this." ;;;; Optimizer Top Level (define (integrate/file file-name syntax-table declarations compute-free?) + compute-free? ; ignored (integrate/kernel (lambda () (phase:syntax (phase:read file-name) syntax-table)) declarations)) @@ -268,12 +271,14 @@ Currently only the 68000 implementation needs this." (integrate/kernel (lambda () (preprocessor input)) declarations) (or receiver (lambda (expression externs events) + externs events ; ignored expression)))) (define (integrate/kernel get-scode declarations) - (fluid-let ((previous-time false) - (previous-name false) - (events '())) + (fluid-let ((previous-real-time false) + (previous-process-time false) + (previous-name false) + (events '())) (transmit-values (transmit-values (transmit-values @@ -317,7 +322,8 @@ Currently only the 68000 implementation needs this." (return-2 (operations->external operations environment) (cgen/expression expression))) -(define previous-time) +(define previous-real-time) +(define previous-process-time) (define previous-name) (define events) @@ -330,12 +336,17 @@ Currently only the 68000 implementation needs this." (set! previous-name this-name)) (define (end-phase) - (let ((this-time (runtime))) - (if previous-time - (let ((dt (- this-time previous-time))) + (let ((this-time (real-time-clock)) + (this-process-time (runtime))) + (if previous-real-time + (let ((dt (- this-time previous-real-time)) + (dpt (- this-process-time previous-process-time))) (set! events (cons (cons previous-name dt) events)) (newline) (write-string " Time: ") - (write dt) - (write-string " seconds."))) - (set! previous-time this-time))) \ No newline at end of file + (write (floor (/ dt 1000.))) + (write-string " seconds (real); ") + (write dpt) + (write-string " seconds (process)."))) + (set! previous-real-time this-time) + (set! previous-process-time this-process-time))) \ No newline at end of file diff --git a/v7/src/sf/usicon.scm b/v7/src/sf/usicon.scm index dad905558..f91f301de 100644 --- a/v7/src/sf/usicon.scm +++ b/v7/src/sf/usicon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.2 1987/05/04 23:50:04 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.3 1988/03/22 17:40:30 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,7 @@ MIT in each case. |# ;;;; SCode Optimizer: Usual Integrations: Constants (declare (usual-integrations)) +(declare (automagic-integrations)) (define usual-integrations/constant-names) (define usual-integrations/constant-values) @@ -63,5 +64,8 @@ MIT in each case. |# usual-integrations/constant-names)) 'DONE) +(declare (integrate-operator constant->integration-info)) + (define (constant->integration-info constant) - (return-2 (constant/make constant) '())) \ No newline at end of file + (declare (integrate constant)) + (return-2 (constant/make constant) '())) diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index ce4b570c5..b75a593fc 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.5 1987/12/23 04:20:38 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.6 1988/03/22 17:40:40 jrm Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,9 @@ MIT in each case. |# ;;;; SCode Optimizer: Usual Integrations: Combination Expansions (declare (usual-integrations)) +(declare (automagic-integrations)) +(declare (open-block-optimizations)) +(declare (eta-substitution)) ;;;; N-ary Arithmetic Predicates @@ -47,6 +50,7 @@ MIT in each case. |# (define (pairwise-test binary-predicate if-left-zero if-right-zero) (lambda (operands if-expanded if-not-expanded block) + block ; ignored (cond ((or (null? operands) (null? (cdr operands))) (error "Too few operands" operands)) @@ -88,6 +92,7 @@ MIT in each case. |# (define (right-accumulation identity make-binary) (lambda (operands if-expanded if-not-expanded block) + block ; ignored (let ((operands (delq identity operands))) (let ((n (length operands))) (cond ((zero? n) @@ -155,6 +160,7 @@ MIT in each case. |# (define (divide-component-expansion divide selector) (lambda (operands if-expanded if-not-expanded block) + if-not-expanded block ; ignored (if-expanded (make-combination selector (list (make-combination divide operands)))))) @@ -176,6 +182,7 @@ MIT in each case. |# (define apply*-expansion (let ((apply-primitive (make-primitive-procedure 'APPLY))) (lambda (operands if-expanded if-not-expanded block) + block ; ignored (let ((n (length operands))) (cond ((< n 2) (error "APPLY*-EXPANSION: Too few arguments" n)) ((< n 10) @@ -187,6 +194,7 @@ MIT in each case. |# (else (if-not-expanded))))))) (define (cons*-expansion operands if-expanded if-not-expanded block) + block ; ignored (let ((n (length operands))) (cond ((zero? n) (error "CONS*-EXPANSION: No arguments!")) ((< n 9) (if-expanded (cons*-expansion-loop operands))) @@ -200,6 +208,7 @@ MIT in each case. |# (cons*-expansion-loop (cdr rest)))))) (define (list-expansion operands if-expanded if-not-expanded block) + block ; ignored (if (< (length operands) 9) (if-expanded (list-expansion-loop operands)) (if-not-expanded))) @@ -215,6 +224,7 @@ MIT in each case. |# (define (general-car-cdr-expansion encoding) (lambda (operands if-expanded if-not-expanded block) + if-not-expanded block ; ignored (if (= (length operands) 1) (if-expanded (make-combination general-car-cdr @@ -264,6 +274,7 @@ MIT in each case. |# ;;;; Miscellaneous (define (make-string-expansion operands if-expanded if-not-expanded block) + block ; ignored (let ((n (length operands))) (cond ((zero? n) (error "MAKE-STRING-EXPANSION: No arguments")) @@ -274,6 +285,7 @@ MIT in each case. |# (define (identity-procedure-expansion operands if-expanded if-not-expanded block) + if-not-expanded block ; ignored (if (not (= (length operands) 1)) (error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments" (length operands))) diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm index 7e6d2c4dc..16fb8fa40 100644 --- a/v7/src/sf/xform.scm +++ b/v7/src/sf/xform.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.5 1987/07/08 04:43:50 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.6 1988/03/22 17:40:50 jrm Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,6 +35,9 @@ MIT in each case. |# ;;;; SCode Optimizer: Transform Input Expression (declare (usual-integrations)) +(declare (eta-substitution)) +(declare (automagic-integrations)) +(declare (open-block-optimizations)) ;;; GLOBAL-BLOCK is used to handle (USUAL-INTEGRATIONS), as follows. ;;; This declaration refers to a large group of names, which are @@ -82,6 +85,8 @@ MIT in each case. |# (transform/expression block environment expression)) expressions)) +(declare (integrate-operator transform/expression)) + (define (transform/expression block environment expression) ((transform/dispatch expression) block environment expression)) @@ -108,7 +113,8 @@ MIT in each case. |# (transform/open-block* (block/make block true) environment))) (define ((transform/open-block* block environment) auxiliary declarations body) - (let ((variables (map (lambda (name) (variable/make block name)) auxiliary))) + (let ((variables (map (lambda (name) (variable/make block name '())) + auxiliary))) (block/set-bound-variables! block (append (block/bound-variables block) variables)) @@ -153,6 +159,7 @@ MIT in each case. |# (define (transform/assignment block environment expression) (assignment-components expression (lambda (name value) + (variable/side-effect! variable) (assignment/make block (environment/lookup block environment name) (transform/expression block environment value))))) @@ -162,7 +169,8 @@ MIT in each case. |# (lambda (name required optional rest body) (let ((block (block/make block true))) (transmit-values - (let ((name->variable (lambda (name) (variable/make block name)))) + (let ((name->variable + (lambda (name) (variable/make block name '())))) (return-3 (map name->variable required) (map name->variable optional) (and rest (name->variable rest)))) @@ -189,6 +197,7 @@ MIT in each case. |# (transform/expression block environment expression))) (define (transform/definition block environment expression) + block environment ; ignored (definition-components expression (lambda (name value) (error "Unscanned definition encountered. Unable to proceed." name)))) @@ -217,6 +226,7 @@ MIT in each case. |# (transform/expression block environment alternative))))) (define (transform/constant block environment expression) + block environment ; ignored (constant/make expression)) (define (transform/declaration block environment expression) @@ -252,6 +262,7 @@ MIT in each case. |# (transform/quotation* expression))))) (define (transform/quotation block environment expression) + block environment ;ignored (transform/quotation* (quotation-expression expression))) (define (transform/quotation* expression) @@ -263,6 +274,7 @@ MIT in each case. |# (transform/expressions block environment (sequence-actions expression)))) (define (transform/the-environment block environment expression) + environment expression ; ignored (block/unsafe! block) (the-environment/make block)) diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm index bead1609e..169238e63 100644 --- a/v8/src/sf/make.scm +++ b/v8/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.15 1988/02/28 23:00:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.16 1988/03/22 17:37:26 jrm Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -61,45 +61,56 @@ MIT in each case. |# (make-environment (define :name "SF") (define :version 3) - (define :modification 15) + (define :modification 16) (define :files) (define :files-lists (list + (cons system-global-environment + '( + "sfmac.bin" ; Macros for SF + )) (cons package/scode-optimizer - '("mvalue.bin" ;Multiple Value Support - "eqsets.bin" ;Set Data Abstraction - "pthmap.bin" ;Pathname Map Abstraction - "object.bin" ;Data Structures - "emodel.bin" ;Environment Model - "gconst.bin" ;Global Primitives List - "usicon.bin" ;Usual Integrations: Constants - "tables.bin" ;Table Abstractions - "packag.bin" ;Global packaging + '( + "mvalue.bin" ; Multiple Value Support + "lsets.bin" ; Set Data Abstraction + "table.bin" ; Table Abstraction + "pthmap.bin" ; Pathname Map Abstraction + "object.bin" ; Data Structures + "emodel.bin" ; Environment Model + "gconst.bin" ; Global Primitives List + "usicon.bin" ; Usual Integrations: Constants + "tables.bin" ; Operation Table Abstractions + "packag.bin" ; Global packaging )) (cons package/top-level - '("toplev.bin")) ;Top Level + '("toplev.bin")) ; Top Level (cons package/transform - '("xform.bin")) ;SCode -> Internal + '("xform.bin")) ; SCode -> Internal (cons package/integrate - '("subst.bin")) ;Beta Substitution Optimizer + '("subst.bin")) ; Beta Substitution Optimizer (cons package/cgen - '("cgen.bin")) ;Internal -> SCode + '("cgen.bin")) ; Internal -> SCode (cons package/expansion - '("usiexp.bin")) ;Usual Integrations: Expanders + '("usiexp.bin")) ; Usual Integrations: Expanders (cons package/declarations - '("pardec.bin")) ;Declaration Parser + '("pardec.bin")) ; Declaration Parser (cons package/copy - '("copy.bin")) ;Copy Expressions + '("copy.bin")) ; Copy Expressions (cons package/free - '("free.bin")) ;Free Variable Analysis + '("free.bin")) ; Free Variable Analysis (cons package/change-type - '("chtype.bin")) ;Type interning + '("chtype.bin")) ; Type interning )))) (load-system! scode-optimizer/system true) (scode-optimizer/initialize!)) +#| + +See also the file SFSF.scm + +|# ;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT ) \ No newline at end of file diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm index 353e0bed3..1f1553c91 100644 --- a/v8/src/sf/toplev.scm +++ b/v8/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.5 1988/02/28 22:59:02 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.6 1988/03/22 17:40:18 jrm Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -35,6 +35,8 @@ MIT in each case. |# ;;;; SCode Optimizer: Top Level (declare (usual-integrations)) +(declare (automagic-integrations)) +(declare (open-block-optimizations)) ;;;; User Interface @@ -259,6 +261,7 @@ Currently only the 68000 implementation needs this." ;;;; Optimizer Top Level (define (integrate/file file-name syntax-table declarations compute-free?) + compute-free? ; ignored (integrate/kernel (lambda () (phase:syntax (phase:read file-name) syntax-table)) declarations)) @@ -268,12 +271,14 @@ Currently only the 68000 implementation needs this." (integrate/kernel (lambda () (preprocessor input)) declarations) (or receiver (lambda (expression externs events) + externs events ; ignored expression)))) (define (integrate/kernel get-scode declarations) - (fluid-let ((previous-time false) - (previous-name false) - (events '())) + (fluid-let ((previous-real-time false) + (previous-process-time false) + (previous-name false) + (events '())) (transmit-values (transmit-values (transmit-values @@ -317,7 +322,8 @@ Currently only the 68000 implementation needs this." (return-2 (operations->external operations environment) (cgen/expression expression))) -(define previous-time) +(define previous-real-time) +(define previous-process-time) (define previous-name) (define events) @@ -330,12 +336,17 @@ Currently only the 68000 implementation needs this." (set! previous-name this-name)) (define (end-phase) - (let ((this-time (runtime))) - (if previous-time - (let ((dt (- this-time previous-time))) + (let ((this-time (real-time-clock)) + (this-process-time (runtime))) + (if previous-real-time + (let ((dt (- this-time previous-real-time)) + (dpt (- this-process-time previous-process-time))) (set! events (cons (cons previous-name dt) events)) (newline) (write-string " Time: ") - (write dt) - (write-string " seconds."))) - (set! previous-time this-time))) \ No newline at end of file + (write (floor (/ dt 1000.))) + (write-string " seconds (real); ") + (write dpt) + (write-string " seconds (process)."))) + (set! previous-real-time this-time) + (set! previous-process-time this-process-time))) \ No newline at end of file -- 2.25.1