From 330178b0c825dc1d6d69926e2d0be7822350ab8b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 10 Mar 1987 13:25:33 +0000 Subject: [PATCH] *** empty log message *** --- v7/src/compiler/base/mvalue.scm | 81 +++++ v7/src/sf/cgen.scm | 195 ++++++++++++ v7/src/sf/copy.scm | 240 +++++++++++++++ v7/src/sf/emodel.scm | 59 ++++ v7/src/sf/free.scm | 128 ++++++++ v7/src/sf/gconst.scm | 119 ++++++++ v7/src/sf/make.scm | 107 +++++++ v7/src/sf/object.scm | 240 +++++++++++++++ v7/src/sf/pardec.scm | 244 +++++++++++++++ v7/src/sf/subst.scm | 524 ++++++++++++++++++++++++++++++++ v7/src/sf/tables.scm | 89 ++++++ v7/src/sf/toplev.scm | 295 ++++++++++++++++++ v7/src/sf/usicon.scm | 61 ++++ v7/src/sf/usiexp.scm | 307 +++++++++++++++++++ v7/src/sf/xform.scm | 265 ++++++++++++++++ v8/src/sf/make.scm | 107 +++++++ v8/src/sf/toplev.scm | 295 ++++++++++++++++++ 17 files changed, 3356 insertions(+) create mode 100644 v7/src/compiler/base/mvalue.scm create mode 100644 v7/src/sf/cgen.scm create mode 100644 v7/src/sf/copy.scm create mode 100644 v7/src/sf/emodel.scm create mode 100644 v7/src/sf/free.scm create mode 100644 v7/src/sf/gconst.scm create mode 100644 v7/src/sf/make.scm create mode 100644 v7/src/sf/object.scm create mode 100644 v7/src/sf/pardec.scm create mode 100644 v7/src/sf/subst.scm create mode 100644 v7/src/sf/tables.scm create mode 100644 v7/src/sf/toplev.scm create mode 100644 v7/src/sf/usicon.scm create mode 100644 v7/src/sf/usiexp.scm create mode 100644 v7/src/sf/xform.scm create mode 100644 v8/src/sf/make.scm create mode 100644 v8/src/sf/toplev.scm diff --git a/v7/src/compiler/base/mvalue.scm b/v7/src/compiler/base/mvalue.scm new file mode 100644 index 000000000..0edf0c712 --- /dev/null +++ b/v7/src/compiler/base/mvalue.scm @@ -0,0 +1,81 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/mvalue.scm,v 3.0 1987/03/10 13:25:05 cph Rel $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Multiple Value Support + +(declare (usual-integrations)) + +(define (transmit-values transmitter receiver) + (transmitter receiver)) + +(define (multiple-value-list transmitter) + (transmitter list)) + +(define (return . values) + (lambda (receiver) + (apply receiver values))) + +;;; For efficiency: + +(define (return-2 v0 v1) + (lambda (receiver) + (receiver v0 v1))) + +(define (return-3 v0 v1 v2) + (lambda (receiver) + (receiver v0 v1 v2))) + +(define (return-4 v0 v1 v2 v3) + (lambda (receiver) + (receiver v0 v1 v2 v3))) + +(define (return-5 v0 v1 v2 v3 v4) + (lambda (receiver) + (receiver v0 v1 v2 v3 v4))) + +(define (return-6 v0 v1 v2 v3 v4 v5) + (lambda (receiver) + (receiver v0 v1 v2 v3 v4 v5))) + +(define (list-multiple first . rest) + (apply call-multiple list first rest)) + +(define (cons-multiple cars cdrs) + (call-multiple cons cars cdrs)) + +(define (call-multiple procedure . transmitters) + (apply return + (apply map + procedure + (map multiple-value-list transmitters)))) \ No newline at end of file diff --git a/v7/src/sf/cgen.scm b/v7/src/sf/cgen.scm new file mode 100644 index 000000000..34b8da7c7 --- /dev/null +++ b/v7/src/sf/cgen.scm @@ -0,0 +1,195 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.0 1987/03/10 13:24:42 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Generate SCode from Expression + +(declare (usual-integrations)) + +(define (cgen/external quotation) + (fluid-let ((flush-declarations? true)) + (cgen/top-level quotation))) + +(define (cgen/external-with-declarations expression) + (fluid-let ((flush-declarations? false)) + (cgen/expression (list false) expression))) + +(define (cgen/top-level quotation) + (let ((block (quotation/block quotation)) + (expression (quotation/expression quotation))) + (cgen/declaration (block/declarations block) + (cgen/expression (list block) expression)))) + +(define (cgen/declaration declarations expression) + (let ((declarations (maybe-flush-declarations declarations))) + (if (null? declarations) + expression + (make-declaration declarations expression)))) + +(define flush-declarations?) + +(define (maybe-flush-declarations declarations) + (if (null? declarations) + '() + (let ((declarations (declarations/original declarations))) + (if flush-declarations? + (begin (for-each (lambda (declaration) + (if (not (declarations/known? declaration)) + (warn "Unused declaration" declaration))) + declarations) + '()) + declarations)))) + +(define (cgen/expressions interns expressions) + (map (lambda (expression) + (cgen/expression interns expression)) + expressions)) + +(define (cgen/expression interns expression) + ((expression/method dispatch-vector expression) interns expression)) + +(define dispatch-vector + (expression/make-dispatch-vector)) + +(define define-method/cgen + (expression/make-method-definer dispatch-vector)) + +(define (cgen/variable interns variable) + (cdr (or (assq variable (cdr interns)) + (let ((association + (cons variable (make-variable (variable/name variable))))) + (set-cdr! interns (cons association (cdr interns))) + association)))) + +(define-method/cgen 'ACCESS + (lambda (interns expression) + (make-access (cgen/expression interns (access/environment expression)) + (access/name expression)))) + +(define-method/cgen 'ASSIGNMENT + (lambda (interns expression) + (make-assignment-from-variable + (cgen/variable interns (assignment/variable expression)) + (cgen/expression interns (assignment/value expression))))) + +(define-method/cgen 'COMBINATION + (lambda (interns expression) + (make-combination + (cgen/expression interns (combination/operator expression)) + (cgen/expressions interns (combination/operands expression))))) + +(define-method/cgen 'CONDITIONAL + (lambda (interns expression) + (make-conditional + (cgen/expression interns (conditional/predicate expression)) + (cgen/expression interns (conditional/consequent expression)) + (cgen/expression interns (conditional/alternative expression))))) + +(define-method/cgen 'CONSTANT + (lambda (interns expression) + (constant/value expression))) + +(define-method/cgen 'DECLARATION + (lambda (interns expression) + (cgen/declaration (declaration/declarations expression) + (cgen/expression interns + (declaration/expression expression))))) + +(define-method/cgen 'DELAY + (lambda (interns expression) + (make-delay (cgen/expression interns (delay/expression expression))))) + +(define-method/cgen 'DISJUNCTION + (lambda (interns expression) + (make-disjunction + (cgen/expression interns (disjunction/predicate expression)) + (cgen/expression interns (disjunction/alternative expression))))) + +(define-method/cgen 'IN-PACKAGE + (lambda (interns expression) + (make-in-package + (cgen/expression interns (in-package/environment expression)) + (cgen/top-level (in-package/quotation expression))))) + +(define-method/cgen 'PROCEDURE + (lambda (interns procedure) + (make-lambda* (variable/name (procedure/name procedure)) + (map variable/name (procedure/required procedure)) + (map variable/name (procedure/optional procedure)) + (let ((rest (procedure/rest procedure))) + (and rest (variable/name rest))) + (let ((block (procedure/block procedure))) + (make-open-block + '() + (maybe-flush-declarations (block/declarations block)) + (cgen/expression (list block) + (procedure/body procedure))))))) + +(define-method/cgen 'OPEN-BLOCK + (lambda (interns expression) + (let ((block (open-block/block expression))) + (make-open-block '() + (maybe-flush-declarations (block/declarations block)) + (cgen/body (list block) expression))))) + +(define (cgen/body interns open-block) + (make-sequence + (let loop + ((variables (open-block/variables open-block)) + (values (open-block/values open-block)) + (actions (open-block/actions open-block))) + (cond ((null? variables) (cgen/expressions interns actions)) + ((null? actions) (error "Extraneous auxiliaries")) + ((eq? (car actions) open-block/value-marker) + (cons (make-definition (variable/name (car variables)) + (cgen/expression interns (car values))) + (loop (cdr variables) (cdr values) (cdr actions)))) + (else + (cons (cgen/expression interns (car actions)) + (loop variables values (cdr actions)))))))) + +(define-method/cgen 'QUOTATION + (lambda (interns expression) + (make-quotation (cgen/top-level expression)))) + +(define-method/cgen 'REFERENCE + (lambda (interns expression) + (cgen/variable interns (reference/variable expression)))) + +(define-method/cgen 'SEQUENCE + (lambda (interns expression) + (make-sequence (cgen/expressions interns (sequence/actions expression))))) + +(define-method/cgen 'THE-ENVIRONMENT + (lambda (interns expression) + (make-the-environment))) \ No newline at end of file diff --git a/v7/src/sf/copy.scm b/v7/src/sf/copy.scm new file mode 100644 index 000000000..802c78cbc --- /dev/null +++ b/v7/src/sf/copy.scm @@ -0,0 +1,240 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.0 1987/03/10 13:24:44 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Copy Expression + +(declare (usual-integrations)) + +(define (copy/external block expression) + (fluid-let ((root-block block)) + (copy/expression block (environment/make) expression))) + +(define (copy/expressions block environment expressions) + (map (lambda (expression) + (copy/expression block environment expression)) + expressions)) + +(define (copy/expression block environment expression) + ((expression/method dispatch-vector expression) + block environment expression)) + +(define dispatch-vector + (expression/make-dispatch-vector)) + +(define define-method/copy + (expression/make-method-definer dispatch-vector)) + +(define (copy/quotation quotation) + (fluid-let ((root-block false)) + (let ((block (quotation/block quotation))) + (quotation/make block + (copy/expression block + (environment/make) + (quotation/expression quotation)))))) + +(define-method/copy 'ACCESS + (lambda (block environment expression) + (access/make (copy/expression block environment + (access/environment expression)) + (access/name expression)))) + +(define-method/copy 'ASSIGNMENT + (lambda (block environment expression) + (assignment/make + block + (copy/variable block environment (assignment/variable expression)) + (copy/expression block environment (assignment/value expression))))) + +(define-method/copy 'COMBINATION + (lambda (block environment expression) + (combination/make + (copy/expression block environment (combination/operator expression)) + (copy/expressions block environment (combination/operands expression))))) + +(define-method/copy 'CONDITIONAL + (lambda (block environment expression) + (conditional/make + (copy/expression block environment (conditional/predicate expression)) + (copy/expression block environment (conditional/consequent expression)) + (copy/expression block environment + (conditional/alternative expression))))) + +(define-method/copy 'CONSTANT + (lambda (block environment expression) + expression)) + +(define-method/copy 'DECLARATION + (lambda (block environment expression) + (declaration/make + (copy/declarations environment (declaration/declarations expression)) + (copy/expression block environment (declaration/expression expression))))) + +(define-method/copy 'DELAY + (lambda (block environment expression) + (delay/make + (copy/expression block environment (delay/expression expression))))) + +(define-method/copy 'DISJUNCTION + (lambda (block environment expression) + (disjunction/make + (copy/expression block environment (disjunction/predicate expression)) + (copy/expression block environment + (disjunction/alternative expression))))) + +(define-method/copy 'IN-PACKAGE + (lambda (block environment expression) + (in-package/make + (copy/expression block environment (in-package/environment expression)) + (copy/quotation (in-package/quotation expression))))) + +(define-method/copy 'PROCEDURE + (lambda (block environment procedure) + (transmit-values (copy/block block environment (procedure/block procedure)) + (lambda (block environment) + (let ((rename (make-renamer environment))) + (procedure/make block + (rename (procedure/name procedure)) + (map rename (procedure/required procedure)) + (map rename (procedure/optional procedure)) + (let ((rest (procedure/rest procedure))) + (and rest (rename rest))) + (copy/expression block + environment + (procedure/body procedure)))))))) + +(define-method/copy 'OPEN-BLOCK + (lambda (block environment expression) + (transmit-values + (copy/block block environment (open-block/block expression)) + (lambda (block environment) + (open-block/make block + (map (make-renamer environment) + (open-block/variables expression)) + (copy/expressions block + environment + (open-block/values expression)) + (map (lambda (action) + (if (eq? action open-block/value-marker) + action + (copy/expression block + environment + action))) + (open-block/actions expression))))))) + +(define-method/copy 'QUOTATION + (lambda (block environment expression) + (copy/quotation expression))) + +(define-method/copy 'REFERENCE + (lambda (block environment expression) + (reference/make block + (copy/variable block + environment + (reference/variable expression))))) + +(define-method/copy 'SEQUENCE + (lambda (block environment expression) + (sequence/make + (copy/expressions block environment (sequence/actions expression))))) + +(define-method/copy 'THE-ENVIRONMENT + (lambda (block environment expression) + (error "Attempt to integrate expression containing (THE-ENVIRONMENT)"))) + +(define (copy/block parent environment block) + (let ((result (block/make parent (block/safe? block))) + (old-bound (block/bound-variables block))) + (let ((new-bound + (map (lambda (variable) + (variable/make result (variable/name 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 environment (block/declarations block))) + (return-2 result environment))))) + +(define (copy/declarations environment declarations) + (if (null? declarations) + '() + (declarations/rename declarations + (lambda (variable) + (environment/lookup environment variable + identity-procedure + (lambda () variable)))))) + +(define root-block) + +(define (copy/variable block environment variable) + (environment/lookup environment variable + identity-procedure + (lambda () + (for-each rename-variable! + (let ((name (variable/name variable))) + (let loop ((block root-block)) + (let ((variable* + (variable/assoc name + (block/bound-variables block)))) + (cond ((not variable*) (loop (block/parent block))) + ((eq? variable variable*) '()) + (else + (cons variable* (loop (block/parent block))))))))) + variable))) + +(define (rename-variable! variable) + (if (block/safe? (variable/block variable)) + (variable/set-name! variable (rename (variable/name variable))) + (error "Integration requires renaming unsafe variable" variable))) + +(define (rename name) + (string->uninterned-symbol (symbol->string name))) + +(define (environment/make) + '()) + +(define (environment/bind environment variables values) + (map* environment cons variables values)) + +(define (environment/lookup environment variable if-found if-not) + (let ((association (assq variable environment))) + (if association + (if-found (cdr association)) + (if-not)))) + +(define (make-renamer environment) + (lambda (variable) + (environment/lookup environment variable + identity-procedure + (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 new file mode 100644 index 000000000..02f11b0dd --- /dev/null +++ b/v7/src/sf/emodel.scm @@ -0,0 +1,59 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.0 1987/03/10 13:24:48 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Environment Model + +(declare (usual-integrations)) + +(define variable/assoc + (association-procedure eq? variable/name)) + +(define (block/unsafe! block) + (if (block/safe? block) + (begin (block/set-safe?! block false) + (if (block/parent block) + (block/unsafe! (block/parent block)))))) + +(define (block/lookup-name block name) + (let search ((block block)) + (or (variable/assoc name (block/bound-variables block)) + (let ((parent (block/parent block))) + (if (not parent) + (variable/make&bind! block name) + (search parent)))))) + +(define (block/lookup-names block names) + (map (lambda (name) + (block/lookup-name block name)) + names)) \ No newline at end of file diff --git a/v7/src/sf/free.scm b/v7/src/sf/free.scm new file mode 100644 index 000000000..15644a51c --- /dev/null +++ b/v7/src/sf/free.scm @@ -0,0 +1,128 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.0 1987/03/10 13:24:54 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Free Variable Analysis + +(declare (usual-integrations)) + +(define (free/expressions expressions) + (if (null? expressions) + eq?-set/null + (eq?-set/union (free/expression (car expressions)) + (free/expressions (cdr expressions))))) + +(define (free/expression expression) + ((expression/method dispatch-vector expression) expression)) + +(define dispatch-vector + (expression/make-dispatch-vector)) + +(define define-method/free + (expression/make-method-definer dispatch-vector)) + +(define-method/free 'ACCESS + (lambda (expression) + (free/expression (access/environment expression)))) + +(define-method/free 'ASSIGNMENT + (lambda (expression) + (eq?-set/adjoin (assignment/variable expression) + (free/expression (assignment/value expression))))) + +(define-method/free 'COMBINATION + (lambda (expression) + (eq?-set/union (free/expression (combination/operator expression)) + (free/expressions (combination/operands expression))))) + +(define-method/free 'CONDITIONAL + (lambda (expression) + (eq?-set/union + (free/expression (conditional/predicate expression)) + (eq?-set/union (free/expression (conditional/consequent expression)) + (free/expression (conditional/alternative expression)))))) + +(define-method/free 'CONSTANT + (lambda (expression) + eq?-set/null)) + +(define-method/free 'DECLARATION + (lambda (expression) + (free/expression (declaration/expression expression)))) + +(define-method/free 'DELAY + (lambda (expression) + (free/expression (delay/expression expression)))) + +(define-method/free 'DISJUNCTION + (lambda (expression) + (eq?-set/union (free/expression (disjunction/predicate expression)) + (free/expression (disjunction/alternative expression))))) + +(define-method/free 'IN-PACKAGE + (lambda (expression) + (free/expression (in-package/environment expression)))) + +(define-method/free 'PROCEDURE + (lambda (expression) + (eq?-set/difference (free/expression (procedure/body expression)) + (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))))) + +(define-method/free 'QUOTATION + (lambda (expression) + eq?-set/null)) + +(define-method/free 'REFERENCE + (lambda (expression) + (eq?-set/singleton (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 diff --git a/v7/src/sf/gconst.scm b/v7/src/sf/gconst.scm new file mode 100644 index 000000000..523b68311 --- /dev/null +++ b/v7/src/sf/gconst.scm @@ -0,0 +1,119 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 3.0 1987/03/10 13:24:58 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Global Constants List + +(declare (usual-integrations)) + +;;; This is a list of names that are bound in the global environment. +;;; Normally the compiler will replace references to one of these +;;; names with the value of that name, which is a constant. + +(define global-constant-objects + '(TRUE FALSE SYSTEM-GLOBAL-ENVIRONMENT + + SCODE-EVAL FORCE WITH-THREADED-CONTINUATION + SET-INTERRUPT-ENABLES! WITH-INTERRUPT-MASK WITH-INTERRUPTS-REDUCED + GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED + PRIMITIVE-PROCEDURE-ARITY NOT FALSE? + STRING->SYMBOL ERROR-PROCEDURE + + ;; Environment + LEXICAL-REFERENCE LEXICAL-ASSIGNMENT LOCAL-ASSIGNMENT + LEXICAL-UNASSIGNED? LEXICAL-UNBOUND? LEXICAL-UNREFERENCEABLE? + + ;; Pointers + EQ? + PRIMITIVE-SET-TYPE MAKE-NON-POINTER-OBJECT + PRIMITIVE-TYPE? PRIMITIVE-TYPE PRIMITIVE-DATUM + OBJECT-DANGEROUS? MAKE-OBJECT-SAFE MAKE-OBJECT-DANGEROUS + + ;; Numbers + ZERO? POSITIVE? NEGATIVE? 1+ -1+ + INTEGER-DIVIDE INTEGER-DIVIDE-QUOTIENT INTEGER-DIVIDE-REMAINDER + TRUNCATE ROUND FLOOR CEILING + SQRT EXP LOG SIN COS + + ;; Basic Compound Datatypes + CONS PAIR? CAR CDR SET-CAR! SET-CDR! GENERAL-CAR-CDR + NULL? LENGTH MEMQ ASSQ FIRST HEAD EMPTY-STREAM? + + VECTOR-CONS VECTOR-LENGTH VECTOR-REF VECTOR-SET! + LIST->VECTOR SUBVECTOR->LIST + + ;; Strings + STRING-ALLOCATE STRING? STRING-REF STRING-SET! + STRING-LENGTH STRING-MAXIMUM-LENGTH SET-STRING-LENGTH! + SUBSTRING=? SUBSTRING-CI=? SUBSTRINGUNSIGNED-INTEGER UNSIGNED-INTEGER->BIT-STRING + READ-BITS! WRITE-BITS! + + MAKE-CELL CELL? CELL-CONTENTS SET-CELL-CONTENTS! + + ;; Characters + MAKE-CHAR CHAR-CODE CHAR-BITS + CHAR-ASCII? ASCII->CHAR CHAR->ASCII + INTEGER->CHAR CHAR->INTEGER + CHAR-UPCASE CHAR-DOWNCASE + + ;; System Compound Datatypes + SYSTEM-PAIR-CONS SYSTEM-PAIR? + SYSTEM-PAIR-CAR SYSTEM-PAIR-SET-CAR! + SYSTEM-PAIR-CDR SYSTEM-PAIR-SET-CDR! + + SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-SET-CXR0! + SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-SET-CXR1! + SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-SET-CXR2! + + SYSTEM-LIST-TO-VECTOR SYSTEM-SUBVECTOR-TO-LIST SYSTEM-VECTOR? + SYSTEM-VECTOR-SIZE SYSTEM-VECTOR-REF SYSTEM-VECTOR-SET! + )) \ No newline at end of file diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm new file mode 100644 index 000000000..dbd401fdf --- /dev/null +++ b/v7/src/sf/make.scm @@ -0,0 +1,107 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.0 1987/03/10 13:25:03 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: System Construction + +(in-package system-global-environment +(declare (usual-integrations)) + +(define sf) +(load "$zcomp/base/load" system-global-environment) + +(load-system system-global-environment + 'PACKAGE/BETA + '(SYSTEM-GLOBAL-ENVIRONMENT) + '( + (PACKAGE/BETA + "mvalue.bin" ;Multiple Value Support + "eqsets.bin" ;Set Data 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 + ) + + (PACKAGE/TOP-LEVEL + "toplev.bin" ;Top Level + ) + + (PACKAGE/TRANSFORM + "xform.bin" ;SCode -> Internal + ) + + (PACKAGE/INTEGRATE + "subst.bin" ;Beta Substitution Optimizer + ) + + (PACKAGE/CGEN + "cgen.bin" ;Internal -> SCode + ) + + (PACKAGE/EXPANSION + "usiexp.bin" ;Usual Integrations: Expanders + ) + + (PACKAGE/DECLARATION-PARSER + "pardec.bin" ;Declaration Parser + ) + + (PACKAGE/COPY + "copy.bin" ;Copy Expressions + ) + + (PACKAGE/FREE + "free.bin" ;Free Variable Analysis + ) + + (PACKAGE/SAFE? + "safep.bin" ;Safety Analysis + ) + + )) + +(in-package package/beta + (define beta/system + (make-environment + (define :name "Beta") + (define :version 3) + (define :modification 0))) + (add-system! beta/system) + (beta/initialize!)) + +;;; 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 new file mode 100644 index 000000000..fef262d60 --- /dev/null +++ b/v7/src/sf/object.scm @@ -0,0 +1,240 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.0 1987/03/10 13:25:07 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Data Types + +(declare (usual-integrations)) + +(let-syntax () + +(define-syntax define-type + (macro (name enumeration slots) + (let ((enumerand (symbol-append name '/ENUMERAND))) + `(BEGIN + (DEFINE ,enumerand + (NAME->ENUMERAND ,(symbol-append 'ENUMERATION/ enumeration) ',name)) + ((ACCESS ADD-UNPARSER-SPECIAL-OBJECT! UNPARSER-PACKAGE) ,enumerand + (LAMBDA (OBJECT) + (UNPARSE-WITH-BRACKETS + (LAMBDA () + (WRITE ',name) + (WRITE-STRING " ") + (WRITE (HASH OBJECT)))))) + (DEFINE ,(symbol-append name '?) (OBJECT/PREDICATE ,enumerand)) + ,@(let loop ((slots slots) (index 1)) + (if (null? slots) + '() + (let ((slot (car slots))) + (let ((ref-name (symbol-append name '/ slot)) + (set-name (symbol-append name '/SET- slot '!))) + `((DECLARE (INTEGRATE-OPERATOR ,ref-name ,set-name)) + (DEFINE (,ref-name ,name) + (DECLARE (INTEGRATE ,name)) + (VECTOR-REF ,name ,index)) + (DEFINE (,set-name ,name ,slot) + (DECLARE (INTEGRATE ,name ,slot)) + (VECTOR-SET! ,name ,index ,slot)) + ,@(loop (cdr slots) (1+ index))))))))))) + +(define-syntax define-simple-type + (macro (name enumeration slots) + (let ((make-name (symbol-append name '/MAKE))) + `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,make-name)) + (DEFINE (,make-name ,@slots) + (DECLARE (INTEGRATE ,@slots)) + (OBJECT/ALLOCATE ,(symbol-append name '/ENUMERAND) ,@slots)) + (DEFINE-TYPE ,name ,enumeration ,slots))))) + +(declare (integrate object/allocate) + (integrate-operator object/enumerand)) + +(define object/allocate vector) + +(define (object/enumerand object) + (declare (integrate object)) + (vector-ref object 0)) + +(define (object/predicate enumerand) + (lambda (object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? enumerand (vector-ref object 0))))) + +;;;; Enumerations + +(define (enumeration/make names) + (let ((enumeration (make-vector (length names)))) + (let loop ((names names) (index 0)) + (if (not (null? names)) + (begin + (vector-set! enumeration index + (vector enumeration (car names) index)) + (loop (cdr names) (1+ index))))) + enumeration)) + +(declare (integrate-operator enumerand/enumeration enumerand/name + enumerand/index enumeration/cardinality + index->enumerand)) + +(define (enumerand/enumeration enumerand) + (declare (integrate enumerand)) + (vector-ref enumerand 0)) + +(define (enumerand/name enumerand) + (declare (integrate enumerand)) + (vector-ref enumerand 1)) + +(define (enumerand/index enumerand) + (declare (integrate enumerand)) + (vector-ref enumerand 2)) + +(define (enumeration/cardinality enumeration) + (declare (integrate enumeration)) + (vector-length enumeration)) + +(define (index->enumerand enumerand index) + (declare (integrate enumerand index)) + (vector-ref enumerand index)) + +(define (name->enumerand enumeration name) + (let ((length (enumeration/cardinality enumeration))) + (let loop ((index 0)) + (and (< index length) + (let ((enumerand (index->enumerand enumeration index))) + (if (eqv? name (enumerand/name enumerand)) + enumerand + (loop (1+ index)))))))) + +;;;; Random Types + +(define enumeration/random + (enumeration/make + '(BLOCK + DELAYED-INTEGRATION + VARIABLE + ))) + +(define-type block random + (parent children safe? declarations bound-variables expression)) + +(define (block/make parent safe?) + (let ((block + (object/allocate block/enumerand parent '() safe? '() '() + false))) + (if parent + (block/set-children! parent (cons block (block/children parent)))) + block)) + +(define-type delayed-integration random + (state environment operations value)) + +(define (delayed-integration/make operations expression) + (object/allocate delayed-integration/enumerand 'NOT-INTEGRATED false + operations expression)) + +(define-simple-type variable random + (block name)) + +(define (variable/make&bind! block name) + (let ((variable (variable/make block name))) + (block/set-bound-variables! block + (cons variable + (block/bound-variables block))) + variable)) + +(define open-block/value-marker + "value marker") + +;;;; Expression Types + +(define enumeration/expression + (enumeration/make + '(ACCESS + ASSIGNMENT + COMBINATION + CONDITIONAL + CONSTANT + DECLARATION + DELAY + DISJUNCTION + IN-PACKAGE + OPEN-BLOCK + PROCEDURE + QUOTATION + REFERENCE + SEQUENCE + THE-ENVIRONMENT + ))) + +(define (expression/make-dispatch-vector) + (make-vector (enumeration/cardinality enumeration/expression))) + +(define (expression/make-method-definer dispatch-vector) + (lambda (type-name method) + (vector-set! dispatch-vector + (enumerand/index + (name->enumerand enumeration/expression type-name)) + method))) + +(declare (integrate-operator expression/method name->method)) + +(define (expression/method dispatch-vector expression) + (declare (integrate dispatch-vector expression)) + (vector-ref dispatch-vector (enumerand/index (object/enumerand expression)))) + +(define (name->method dispatch-vector name) + ;; Useful for debugging + (declare (integrate dispatch-vector name)) + (vector-ref dispatch-vector + (enumerand/index (name->enumerand enumeration/expression name)))) + +(define-simple-type access expression (environment name)) +(define-simple-type assignment expression (block variable value)) +(define-simple-type combination expression (operator operands)) +(define-simple-type conditional expression (predicate consequent alternative)) +(define-simple-type constant expression (value)) +(define-simple-type declaration expression (declarations expression)) +(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 procedure expression + (block name required optional rest body)) +(define-simple-type quotation expression (block expression)) +(define-simple-type reference expression (block variable)) +(define-simple-type sequence expression (actions)) +(define-simple-type the-environment expression (block)) + +;;; end LET-SYNTAX +) \ No newline at end of file diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm new file mode 100644 index 000000000..7c35a7de6 --- /dev/null +++ b/v7/src/sf/pardec.scm @@ -0,0 +1,244 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.0 1987/03/10 13:25:13 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Parse Declarations + +(declare (usual-integrations)) + +(define (declarations/known? declaration) + (assq (car declaration) known-declarations)) + +(define (declarations/parse block declarations) + (return-2 + declarations + (accumulate + (lambda (declaration bindings) + (let ((association (assq (car declaration) known-declarations))) + (if (not association) + bindings + (transmit-values (cdr association) + (lambda (before-bindings? parser) + (let ((block + (if before-bindings? + (let ((block (block/parent block))) + (if (block/parent block) + (warn "Declaration not at top level" + declaration)) + block) + block))) + (parser block (bindings/cons block before-bindings?) bindings + (cdr declaration)))))))) + (return-2 '() '()) + declarations))) + +(define (declarations/rename declarations rename) + (declarations/map declarations + (lambda (bindings) + (map (lambda (binding) + (transmit-values binding + (lambda (applicator binder names) + (return-3 applicator binder (map rename names))))) + bindings)))) + +(define (declarations/binders declarations) + (transmit-values declarations + (lambda (original bindings) + (call-multiple (lambda (bindings) + (lambda (operations) + (accumulate (lambda (binding operations) + (transmit-values binding + (lambda (applicator binder names) + (applicator binder operations + names)))) + operations bindings))) + bindings)))) + +(define (declarations/original declarations) + (transmit-values declarations + (lambda (original bindings) + original))) + +(define (declarations/map declarations procedure) + (transmit-values declarations + (lambda (original bindings) + (return-2 original (call-multiple procedure bindings))))) + +(define (bindings/cons block before-bindings?) + (lambda (bindings applicator names global?) + (let ((result + (if global? + (return-3 applicator operations/bind-global names) + (return-3 applicator operations/bind + (block/lookup-names block names))))) + (transmit-values bindings + (lambda (before-bindings after-bindings) + (if before-bindings? + (return-2 (cons result before-bindings) after-bindings) + (return-2 before-bindings (cons result after-bindings)))))))) + +(define (bind/values table/cons table operation export? names values) + (table/cons table + (lambda (binder operations names) + (binder operations operation export? names values)) + names + (not export?))) + +(define (bind/no-values table/cons table operation export? names) + (table/cons table + (lambda (binder operations names) + (binder operations operation export? names)) + names + false)) + +(define (accumulate cons table items) + (let loop ((table table) (items items)) + (if (null? items) + table + (loop (cons (car items) table) (cdr items))))) + +(define (define-declaration name before-bindings? parser) + (let ((entry (assq name known-declarations))) + (if entry + (set-cdr! entry (return-2 before-bindings? parser)) + (set! known-declarations + (cons (cons name (return-2 before-bindings? parser)) + known-declarations))))) + +(define known-declarations + '()) + +;;;; Integration of System Constants + +(define-declaration 'USUAL-INTEGRATIONS true + (lambda (block table/cons table deletions) + (let ((finish + (lambda (table operation names values) + (transmit-values + (if (null? deletions) + (return-2 names values) + (let deletion-loop ((names names) (values values)) + (cond ((null? names) (return-2 '() '())) + ((memq (car names) deletions) + (deletion-loop (cdr names) (cdr values))) + (else + (cons-multiple + (return-2 (car names) (car values)) + (deletion-loop (cdr names) (cdr values))))))) + (lambda (names values) + (bind/values table/cons table operation false names + values)))))) + (finish (finish table 'INTEGRATE + usual-integrations/constant-names + usual-integrations/constant-values) + 'EXPAND + usual-integrations/expansion-names + usual-integrations/expansion-values)))) + +(define-declaration 'INTEGRATE-PRIMITIVE-PROCEDURES false + (lambda (block table/cons table specifications) + (transmit-values + (let loop ((specifications specifications)) + (if (null? specifications) + (return-2 '() '()) + (cons-multiple (parse-primitive-specification + block + (car specifications)) + (loop (cdr specifications))))) + (lambda (names values) + (bind/values table/cons table 'INTEGRATE true names values))))) + +(define (parse-primitive-specification block specification) + (let ((finish + (lambda (variable-name primitive-name) + (return-2 (block/lookup-name block variable-name) + (make-primitive-procedure + (constant->integration-info primitive-name)))))) + (cond ((and (pair? specification) + (symbol? (car specification)) + (pair? (cdr specification)) + (symbol? (cadr specification)) + (null? (cddr specification))) + (finish (first specification) (second specification))) + ((symbol? specification) (finish specification specification)) + (else (error "Bad primitive specification" specification))))) + +;;;; Integration of User Code + +(define-declaration 'INTEGRATE false + (lambda (block table/cons table names) + (bind/no-values table/cons table 'INTEGRATE true names))) + +(define-declaration 'INTEGRATE-OPERATOR false + (lambda (block table/cons table names) + (bind/no-values table/cons table 'INTEGRATE-OPERATOR true names))) + +(define-declaration 'INTEGRATE-EXTERNAL true + (lambda (block table/cons table specifications) + (accumulate + (lambda (extern table) + (bind/values table/cons table (vector-ref extern 1) false + (list (vector-ref extern 0)) + (list + (expression->integration-info + (transform/expression-with-block + block + (vector-ref extern 2)))))) + table + (mapcan read-externs-file + (mapcan specification->pathnames specifications))))) + +(define (specification->pathnames specification) + (let ((value + (scode-eval (syntax specification system-global-syntax-table) + (access syntax-environment syntaxer-package)))) + (if (pair? value) + (map ->pathname value) + (list (->pathname value))))) + +(define (expression->integration-info expression) + (lambda () + expression)) + +(define (operations->external operations environment) + (operations/extract-external operations + (lambda (variable operation info if-ok if-not) + (let ((finish + (lambda (value) + (if-ok + (vector (variable/name variable) + operation + (cgen/expression-with-declarations value)))))) + (if info + (finish info) + (variable/final-value variable environment finish if-not)))))) \ No newline at end of file diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm new file mode 100644 index 000000000..8c779929d --- /dev/null +++ b/v7/src/sf/subst.scm @@ -0,0 +1,524 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.0 1987/03/10 13:25:18 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Beta Substitution + +(declare (usual-integrations)) + +(define (integrate/top-level block expression) + (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))) + (if (null? declarations) + (operations/shadow operations (block/bound-variables block)) + (transmit-values (declarations/binders declarations) + (lambda (before-bindings after-bindings) + (after-bindings + (operations/shadow (before-bindings operations) + (block/bound-variables block)))))))) + +(define (integrate/expressions operations environment expressions) + (map (lambda (expression) + (integrate/expression operations environment expression)) + expressions)) + +(define (integrate/expression operations environment expression) + ((expression/method dispatch-vector expression) + operations environment expression)) + +(define dispatch-vector + (expression/make-dispatch-vector)) + +(define define-method/integrate + (expression/make-method-definer dispatch-vector)) + +;;;; Lookup + +(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)) + (else (error "Unknown operation" operation)))) + (lambda () expression)))) + +(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/combination operations + environment + (integrate/name operator info environment) + operands)) + ((EXPAND) + (info operands + identity-procedure ;expanded value can't be optimized further. + dont-integrate)) + (else (error "Unknown operation" operation)))) + dont-integrate))) + +(define-method/integrate 'ASSIGNMENT + (lambda (operations environment assignment) + (let ((variable (assignment/variable assignment))) + (operations/lookup operations variable + (lambda (operation info) + (case operation + ((INTEGRATE INTEGRATE-OPERATOR EXPAND) + (warn "Attempt to assign integrated name" + (variable/name variable))) + (else (error "Unknown operation" operation)))) + (lambda () 'DONE)) + (assignment/make (assignment/block assignment) + variable + (integrate/expression operations + environment + (assignment/value assignment)))))) + +;;;; Binding + +(define-method/integrate 'OPEN-BLOCK + (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)))))) + +(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)))) + +(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))))) + +(define-method/integrate 'PROCEDURE + integrate/procedure) + +(define-method/integrate 'COMBINATION + (lambda (operations environment combination) + (integrate/combination + operations + environment + (combination/operator combination) + (integrate/expressions operations + environment + (combination/operands combination))))) + +(define (integrate/combination operations environment operator operands) + (if (reference? operator) + (integrate/reference-operator operations + environment + operator + operands) + (combination/optimizing-make + (if (procedure? operator) + (integrate/procedure-operator operations + environment + operator + operands) + (let ((operator + (integrate/expression operations environment operator))) + (if (procedure? operator) + (integrate/procedure-operator operations + environment + operator + operands) + operator))) + operands))) + +(define (integrate/procedure-operator operations environment procedure + operands) + (integrate/procedure operations + (simulate-application environment procedure operands) + procedure)) + +(define-method/integrate 'DECLARATION + (lambda (operations environment declaration) + (let ((declarations (declaration/declarations declaration))) + (declaration/make + declarations + (transmit-values (declarations/binders declarations) + (lambda (before-bindings after-bindings) + (integrate/expression (after-bindings (before-bindings operations)) + environment + (declaration/expression declaration)))))))) + +;;;; Easy Cases + +(define-method/integrate 'CONSTANT + (lambda (operations environment expression) + expression)) + +(define-method/integrate 'THE-ENVIRONMENT + (lambda (operations environment expression) + expression)) + +(define-method/integrate 'QUOTATION + (lambda (operations environment expression) + (integrate/quotation expression))) + +(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))))) + +(define-method/integrate 'DISJUNCTION + (lambda (operations environment expression) + (disjunction/make + (integrate/expression operations environment + (disjunction/predicate expression)) + (integrate/expression operations environment + (disjunction/alternative expression))))) + +(define-method/integrate 'SEQUENCE + (lambda (operations environment expression) + (sequence/make + (integrate/expressions operations environment + (sequence/actions expression))))) + +(define-method/integrate 'ACCESS + (lambda (operations environment expression) + (access/make (integrate/expression operations environment + (access/environment expression)) + (access/name expression)))) + +(define-method/integrate 'DELAY + (lambda (operations environment expression) + (delay/make + (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/environment expression)) + (integrate/quotation (in-package/quotation expression))))) + +(define (integrate/quotation quotation) + (transmit-values (integrate/top-level (quotation/block quotation) + (quotation/expression quotation)) + (lambda (operations environment expression) + expression))) + +;;;; Environment + +(define (environment/recursive-bind operations environment variables values) + ;; Used to implement mutually-recursive definitions that can + ;; integrate one another. When circularities are detected within + ;; the definition-reference graph, integration is disabled. + (let ((values + (map (lambda (value) + (delayed-integration/make operations value)) + values))) + (let ((environment + (environment/bind-multiple environment variables values))) + (for-each (lambda (value) + (delayed-integration/set-environment! value environment)) + values) + (return-2 environment + (map delayed-integration/force values))))) + +(define (integrate/name reference info environment) + (let ((variable (reference/variable reference))) + (let ((finish + (lambda (value) + (copy/expression (reference/block reference) value)))) + (if info + (finish (info)) + (environment/lookup environment variable + (lambda (value) + (if (delayed-integration? value) + (if (delayed-integration/in-progress? value) + reference + (finish (delayed-integration/force value))) + (finish value))) + (lambda () reference)))))) + +(define (variable/final-value variable environment if-value if-not) + (environment/lookup environment variable + (lambda (value) + (if (delayed-integration? value) + (if (delayed-integration/in-progress? value) + (error "Unfinished integration" value) + (if-value (delayed-integration/force value))) + (if-value value))) + (lambda () + (warn "Unable to integrate" (variable/name variable)) + (if-not)))) + +(define (simulate-application environment procedure operands) + + (define (match-required environment required operands) + (cond ((null? required) + (match-optional environment + (procedure/optional procedure) + operands)) + ((null? operands) + (error "Too few operands in call to procedure" procedure)) + (else + (match-required (environment/bind environment + (car required) + (car operands)) + (cdr required) + (cdr operands))))) + + (define (match-optional environment optional operands) + (cond ((null? optional) + (match-rest environment (procedure/rest procedure) operands)) + ((null? operands) + (match-rest environment (procedure/rest procedure) '())) + (else + (match-optional (environment/bind environment + (car optional) + (car operands)) + (cdr optional) + (cdr operands))))) + + (define (match-rest environment rest operands) + (cond (rest + ;; Other cases are too hairy -- don't bother. + (if (null? operands) + (environment/bind environment rest (constant/make '())) + environment)) + ((null? operands) + environment) + (else + (error "Too many operands in call to procedure" procedure)))) + + (match-required environment (procedure/required procedure) operands)) + +(define (environment/make) + '()) + +(define (environment/bind environment variable value) + (cons (cons variable value) environment)) + +(define (environment/bind-multiple environment variables values) + (map* environment cons variables values)) + +(define (environment/lookup environment variable if-found if-not) + (let ((association (assq variable environment))) + (if association + (if-found (cdr association)) + (if-not)))) + +(define (delayed-integration/in-progress? delayed-integration) + (eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED)) + +(define (delayed-integration/force delayed-integration) + (case (delayed-integration/state delayed-integration) + ((NOT-INTEGRATED) + (let ((value + (let ((environment + (delayed-integration/environment delayed-integration)) + (operations + (delayed-integration/operations delayed-integration)) + (expression (delayed-integration/value delayed-integration))) + (delayed-integration/set-state! delayed-integration + 'BEING-INTEGRATED) + (delayed-integration/set-environment! delayed-integration false) + (delayed-integration/set-operations! delayed-integration false) + (delayed-integration/set-value! delayed-integration false) + (integrate/expression operations environment expression)))) + (delayed-integration/set-state! delayed-integration 'INTEGRATED) + (delayed-integration/set-value! delayed-integration value))) + ((INTEGRATED) 'DONE) + ((BEING-INTEGRATED) + (error "Attempt to re-force delayed integration" delayed-integration)) + (else + (error "Delayed integration has unknown state" delayed-integration))) + (delayed-integration/value delayed-integration)) + +;;;; Optimizations + +(define combination/optimizing-make) +(let () + +(set! combination/optimizing-make + (lambda (operator operands) + (let ((dont-optimize + (lambda () + (combination/make 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)))) + (let ((body (procedure/body operator))) + (let ((referenced (free/expression body))) + (if (not (memq (procedure/name operator) + referenced)) ;i.e. not a loop + ;; Simple LET-like combination. Delete any + ;; unreferenced parameters. If no parameters + ;; remain, delete the combination and lambda. + (transmit-values + ((delete-unused-parameters referenced) + (procedure/required operator) + operands) + (lambda (required operands) + (if (null? required) + body + (combination/make + (procedure/make (procedure/block operator) + (procedure/name operator) + required '() false body) + operands)))) + (dont-optimize)))) + (dont-optimize))))) + +(define (delete-unused-parameters referenced) + (define (loop parameters operands) + (if (null? parameters) + (return-2 '() operands) + (let ((rest (loop (cdr parameters) (cdr operands)))) + (if (memq (car parameters) referenced) + (transmit-values rest + (lambda (parameters* operands*) + (return-2 (cons (car parameters) parameters*) + (cons (car operands) operands*)))) + rest)))) + loop) + +;;; end COMBINATION/OPTIMIZING-MAKE +) + +#| This is too much of a pain to do now. Maybe later. + +(define procedure/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) + '() + (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 diff --git a/v7/src/sf/tables.scm b/v7/src/sf/tables.scm new file mode 100644 index 000000000..5fd4b22f7 --- /dev/null +++ b/v7/src/sf/tables.scm @@ -0,0 +1,89 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.0 1987/03/10 13:25:22 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Tables + +(declare (usual-integrations)) + +;;;; Operations + +(define (operations/make) + (cons '() '())) + +(define (operations/lookup operations variable if-found if-not) + (let ((entry (assq variable (car operations))) + (finish + (lambda (entry) + (if-found (vector-ref (cdr entry) 1) + (vector-ref (cdr entry) 2))))) + (if entry + (if (cdr entry) (finish entry) (if-not)) + (let ((entry (assq (variable/name variable) (cdr operations)))) + (if entry (finish entry) (if-not)))))) + +(define (operations/shadow operations variables) + (cons (map* (car operations) + (lambda (variable) (cons variable false)) + variables) + (cdr operations))) + +(define (operations/bind-global operations operation export? names values) + (cons (car operations) + (map* (cdr operations) + (lambda (name value) + (cons name (vector export? operation value))) + names values))) + +(define (operations/bind operations operation export? names #!optional values) + (cons (let ((make-binding + (lambda (name value) + (cons name (vector export? operation value))))) + (if (unassigned? values) + (map* (car operations) + (lambda (name) (make-binding name false)) + names) + (map* (car operations) make-binding names values))) + (cdr operations))) + +(define (operations/extract-external operations procedure) + (let loop ((elements (car operations))) + (if (null? elements) + '() + (let ((value (cdar elements)) (rest (loop (cdr elements)))) + (if (and value (vector-ref value 0)) + (procedure (caar elements) (vector-ref value 1) + (vector-ref value 2) + (lambda (value) (cons value rest)) + (lambda () rest)) + rest))))) \ No newline at end of file diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm new file mode 100644 index 000000000..5569392fc --- /dev/null +++ b/v7/src/sf/toplev.scm @@ -0,0 +1,295 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.0 1987/03/10 13:25:25 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Top Level + +(declare (usual-integrations)) + +;;;; User Interface + +(define generate-unfasl-files? false + "Set this non-false to cause unfasl files to be generated by default.") + +(define optimize-open-blocks? false + "Set this non-false to eliminate unreferenced auxiliary definitions. +Currently this optimization is not implemented.") + +(define (integrate/procedure procedure declarations) + (if (compound-procedure? procedure) + (procedure-components procedure + (lambda (*lambda environment) + (scode-eval (integrate/scode *lambda declarations false) + environment))) + (error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure))) + +(define (integrate/sexp s-expression declarations receiver) + (integrate/simple phase:syntax (list s-expression) declarations receiver)) + +(define (integrate/scode scode declarations receiver) + (integrate/simple identity-procedure scode declarations receiver)) + +(define (sf input-string #!optional bin-string spec-string) + (if (unassigned? bin-string) (set! bin-string false)) + (if (unassigned? spec-string) (set! spec-string false)) + (syntax-file input-string bin-string spec-string)) + +(define (scold input-string #!optional bin-string spec-string) + "Use this only for syntaxing the cold-load root file. +Currently only the 68000 implementation needs this." + (if (unassigned? bin-string) (set! bin-string false)) + (if (unassigned? spec-string) (set! spec-string false)) + (fluid-let ((wrapping-hook wrap-with-control-point)) + (syntax-file input-string bin-string spec-string))) + +;;;; File Syntaxer + +(define sf/default-input-pathname + (make-pathname false false false "scm" 'NEWEST)) + +(define sf/default-externs-pathname + (make-pathname false false false "ext" 'NEWEST)) + +(define sf/output-pathname-type "bin") +(define sf/unfasl-pathname-type "unf") + +(define (syntax-file input-string bin-string spec-string) + (let ((eval-sf-expression + (lambda (input-string) + (let ((input-path + (pathname->input-truename + (merge-pathnames (->pathname input-string) + sf/default-input-pathname)))) + (if (not input-path) + (error "SF: File does not exist" input-string)) + (let ((bin-path + (let ((bin-path + (pathname-new-type input-path + sf/output-pathname-type))) + (if bin-string + (merge-pathnames (->pathname bin-string) bin-path) + bin-path)))) + (let ((spec-path + (and (or spec-string generate-unfasl-files?) + (let ((spec-path + (pathname-new-type bin-path + sf/unfasl-pathname-type))) + (if spec-string + (merge-pathnames (->pathname spec-string) + spec-path) + spec-path))))) + (syntax-file* input-path bin-path spec-path))))))) + (if (list? input-string) + (for-each (lambda (input-string) + (eval-sf-expression input-string)) + input-string) + (eval-sf-expression input-string))) + *the-non-printing-object*) + +(define (syntax-file* input-pathname bin-pathname spec-pathname) + (let ((start-date (date)) + (start-time (time)) + (input-filename (pathname->string input-pathname)) + (bin-filename (pathname->string bin-pathname)) + (spec-filename (and spec-pathname (pathname->string spec-pathname)))) + (newline) + (write-string "Syntax file: ") + (write input-filename) + (write-string " ") + (write bin-filename) + (write-string " ") + (write spec-filename) + (transmit-values (integrate/file input-pathname '() spec-pathname) + (lambda (expression externs events) + (fasdump (wrapping-hook + (make-comment `((SOURCE-FILE . ,input-filename) + (DATE . ,start-date) + (TIME . ,start-time) + (FLUID-LET . ,*fluid-let-type*)) + (set! expression false))) + bin-pathname) + (write-externs-file (pathname-new-type + bin-pathname + (pathname-type sf/default-externs-pathname)) + (set! externs false)) + (if spec-pathname + (begin (newline) + (write-string "Writing ") + (write spec-filename) + (with-output-to-file spec-pathname + (lambda () + (newline) + (write `(DATE ,start-date ,start-time)) + (newline) + (write `(FLUID-LET ,*fluid-let-type*)) + (newline) + (write `(SOURCE-FILE ,input-filename)) + (newline) + (write `(BINARY-FILE ,bin-filename)) + (for-each (lambda (event) + (newline) + (write `(,(car event) + (RUNTIME ,(cdr event))))) + events))) + (write-string " -- done"))))))) + +(define (read-externs-file pathname) + (fasload (merge-pathnames (->pathname pathname) + sf/default-externs-pathname))) + +(define (write-externs-file pathname externs) + (if (not (null? externs)) + (fasdump externs pathname))) + +(define (print-spec identifier names) + (newline) + (newline) + (write-string "(") + (write identifier) + (let loop + ((names + (sort names + (lambda (x y) + (stringstring x) + (symbol->string y)))))) + (if (not (null? names)) + (begin (newline) + (write (car names)) + (loop (cdr names))))) + (write-string ")")) + +(define (wrapping-hook scode) + scode) + +(define control-point-tail + `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4)) + () () () () () () () () () () () () () () ())) + +(define (wrap-with-control-point scode) + (system-list-to-vector type-code-control-point + `(,return-address-restart-execution + ,scode + ,system-global-environment + ,return-address-non-existent-continuation + ,@control-point-tail))) + +(define type-code-control-point + (microcode-type 'CONTROL-POINT)) + +(define return-address-restart-execution + (make-return-address (microcode-return 'RESTART-EXECUTION))) + +(define return-address-non-existent-continuation + (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION))) + +;;;; Optimizer Top Level + +(define (integrate/file file-name declarations compute-free?) + (integrate/kernel (lambda () + (phase:syntax (phase:read file-name))) + declarations)) + +(define (integrate/simple preprocessor input declarations receiver) + (transmit-values + (integrate/kernel (lambda () (preprocessor input)) declarations) + (or receiver + (lambda (expression externs events) + expression)))) + +(define (integrate/kernel get-scode declarations) + (fluid-let ((previous-time false) + (previous-name false) + (events '())) + (transmit-values + (transmit-values + (transmit-values + (phase:transform (canonicalize-scode (get-scode) declarations)) + phase:optimize) + phase:generate-scode) + (lambda (externs expression) + (end-phase) + (return-3 expression externs (reverse! events)))))) + +(define (canonicalize-scode scode declarations) + (let ((declarations + ((access process-declarations syntaxer-package) declarations))) + (if (null? declarations) + scode + (scan-defines (make-sequence + (list (make-block-declaration declarations) + scode)) + make-open-block)))) + +(define (phase:read filename) + (mark-phase "Read") + (read-file filename)) + +(define (phase:syntax s-expression) + (mark-phase "Syntax") + (syntax* s-expression (make-syntax-table system-global-syntax-table))) + +(define (phase:transform scode) + (mark-phase "Transform") + (transform/expression scode)) + +(define (phase:optimize block expression) + (mark-phase "Optimize") + (integrate/expression block expression)) + +(define (phase:generate-scode operations environment expression) + (mark-phase "Generate SCode") + (return-2 (operations->external operations environment) + (cgen/expression expression))) + +(define previous-time) +(define previous-name) +(define events) + +(define (mark-phase this-name) + (end-phase) + (newline) + (write-string " ") + (write-string this-name) + (write-string "...") + (set! previous-name this-name)) + +(define (end-phase) + (let ((this-time (runtime))) + (if previous-time + (let ((dt (- this-time previous-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 diff --git a/v7/src/sf/usicon.scm b/v7/src/sf/usicon.scm new file mode 100644 index 000000000..029c2cc9c --- /dev/null +++ b/v7/src/sf/usicon.scm @@ -0,0 +1,61 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.0 1987/03/10 13:25:28 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Usual Integrations: Constants + +(declare (usual-integrations)) + +(define usual-integrations/constant-names) +(define usual-integrations/constant-values) + +(define (constant->integration-info constant) + (lambda () + (constant/make constant))) + +(define (usual-integrations/delete-constant! name) + (set! global-constant-objects (delq! name global-constant-objects)) + (usual-integrations/cache!)) + +(define (usual-integrations/cache!) + (set! usual-integrations/constant-names + (list-copy global-constant-objects)) + (set! usual-integrations/constant-values + (map (lambda (name) + (let ((object + (lexical-reference system-global-environment name))) + (if (not (scode-constant? object)) + (error "USUAL-INTEGRATIONS: not a constant" name)) + (constant->integration-info object))) + usual-integrations/constant-names)) + (return-2 (constant/make constant) '())) \ No newline at end of file diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm new file mode 100644 index 000000000..d9ced17da --- /dev/null +++ b/v7/src/sf/usiexp.scm @@ -0,0 +1,307 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.0 1987/03/10 13:25:31 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Usual Integrations: Combination Expansions + +(declare (usual-integrations)) + +;;;; N-ary Arithmetic Predicates + +(define (make-combination primitive operands) + (combination/make (constant/make primitive) operands)) + +(define (constant-eq? expression constant) + (and (constant? expression) + (eq? (constant/value expression) constant))) + +(define (pairwise-test binary-predicate if-left-zero if-right-zero) + (lambda (operands if-expanded if-not-expanded) + (cond ((or (null? operands) + (null? (cdr operands))) + (error "Too few operands" operands)) + ((null? (cddr operands)) + (if-expanded + (cond ((constant-eq? (car operands) 0) + (make-combination if-left-zero (list (cadr operands)))) + ((constant-eq? (cadr operands) 0) + (make-combination if-right-zero (list (car operands)))) + (else + (make-combination binary-predicate operands))))) + (else + (if-not-expanded))))) + +(define (pairwise-test-inverse inverse-expansion) + (lambda (operands if-expanded if-not-expanded) + (inverse-expansion operands + (lambda (expression) + (if-expanded (make-combination not (list expression)))) + if-not-expanded))) + +(define =-expansion + (pairwise-test (make-primitive-procedure '&=) zero? zero?)) + +(define <-expansion + (pairwise-test (make-primitive-procedure '&<) positive? negative?)) + +(define >-expansion + (pairwise-test (make-primitive-procedure '&>) negative? positive?)) + +(define <=-expansion + (pairwise-test-inverse >-expansion)) + +(define >=-expansion + (pairwise-test-inverse <-expansion)) + +;;;; N-ary Arithmetic Field Operations + +(define (right-accumulation identity make-binary) + (lambda (operands if-expanded if-not-expanded) + (let ((operands (delq identity operands))) + (let ((n (length operands))) + (cond ((zero? n) + (if-expanded (constant/make identity))) + ((< n 5) + (if-expanded + (let loop + ((first (car operands)) + (rest (cdr operands))) + (if (null? rest) + first + (make-binary first + (loop (car rest) (cdr rest))))))) + (else + (if-not-expanded))))))) + +(define +-expansion + (right-accumulation 0 + (let ((&+ (make-primitive-procedure '&+))) + (lambda (x y) + (cond ((constant-eq? x 1) (make-combination 1+ (list y))) + ((constant-eq? y 1) (make-combination 1+ (list x))) + (else (make-combination &+ (list x y)))))))) + +(define *-expansion + (right-accumulation 1 + (let ((&* (make-primitive-procedure '&*))) + (lambda (x y) + (make-combination &* (list x y)))))) + +(define (right-accumulation-inverse identity inverse-expansion make-binary) + (lambda (operands if-expanded if-not-expanded) + (let ((expand + (lambda (x y) + (if-expanded + (if (constant-eq? y identity) + x + (make-binary x y)))))) + (cond ((null? operands) + (error "Too few operands")) + ((null? (cdr operands)) + (expand (constant/make identity) (car operands))) + (else + (inverse-expansion (cdr operands) + (lambda (expression) + (expand (car operands) expression)) + if-not-expanded)))))) + +(define --expansion + (right-accumulation-inverse 0 +-expansion + (let ((&- (make-primitive-procedure '&-))) + (lambda (x y) + (if (constant-eq? y 1) + (make-combination -1+ (list x)) + (make-combination &- (list x y))))))) + +(define /-expansion + (right-accumulation-inverse 1 *-expansion + (let ((&/ (make-primitive-procedure '&/))) + (lambda (x y) + (make-combination &/ (list x y)))))) + +;;;; Miscellaneous Arithmetic + +(define (divide-component-expansion selector) + (lambda (operands if-expanded if-not-expanded) + (if-expanded + (make-combination selector + (list (make-combination integer-divide operands)))))) + +(define quotient-expansion + (divide-component-expansion car)) + +(define remainder-expansion + (divide-component-expansion cdr)) + +;;;; N-ary List Operations + +(define apply*-expansion + (let ((apply-primitive (make-primitive-procedure 'APPLY))) + (lambda (operands if-expanded if-not-expanded) + (let ((n (length operands))) + (cond ((< n 2) (error "APPLY*-EXPANSION: Too few arguments" n)) + ((< n 10) + (if-expanded + (make-combination + apply-primitive + (list (car operands) + (cons*-expansion-loop (cdr operands)))))) + (else (if-not-expanded))))))) + +(define (cons*-expansion operands if-expanded if-not-expanded) + (let ((n (length operands))) + (cond ((zero? n) (error "CONS*-EXPANSION: No arguments!")) + ((< n 9) (if-expanded (cons*-expansion-loop operands))) + (else (if-not-expanded))))) + +(define (cons*-expansion-loop rest) + (if (null? (cdr rest)) + (car rest) + (make-combination cons + (list (car rest) + (cons*-expansion-loop (cdr rest)))))) + +(define (list-expansion operands if-expanded if-not-expanded) + (if (< (length operands) 9) + (if-expanded (list-expansion-loop operands)) + (if-not-expanded))) + +(define (vector-expansion operands if-expanded if-not-expanded) + (if (< (length operands) 9) + (if-expanded (make-combination list->vector + (list (list-expansion-loop operands)))) + (if-not-expanded))) + +(define (list-expansion-loop rest) + (if (null? rest) + (constant/make '()) + (make-combination cons + (list (car rest) + (list-expansion-loop (cdr rest)))))) + +;;;; General CAR/CDR Encodings + +(define (general-car-cdr-expansion encoding) + (lambda (operands if-expanded if-not-expanded) + (if (= (length operands) 1) + (if-expanded + (make-combination general-car-cdr + (list (car operands) + (constant/make encoding)))) + (error "Wrong number of arguments" (length operands))))) + +(define caar-expansion (general-car-cdr-expansion #b111)) +(define cadr-expansion (general-car-cdr-expansion #b110)) +(define cdar-expansion (general-car-cdr-expansion #b101)) +(define cddr-expansion (general-car-cdr-expansion #b100)) + +(define caaar-expansion (general-car-cdr-expansion #b1111)) +(define caadr-expansion (general-car-cdr-expansion #b1110)) +(define cadar-expansion (general-car-cdr-expansion #b1101)) +(define caddr-expansion (general-car-cdr-expansion #b1100)) +(define cdaar-expansion (general-car-cdr-expansion #b1011)) +(define cdadr-expansion (general-car-cdr-expansion #b1010)) +(define cddar-expansion (general-car-cdr-expansion #b1001)) +(define cdddr-expansion (general-car-cdr-expansion #b1000)) + +(define caaaar-expansion (general-car-cdr-expansion #b11111)) +(define caaadr-expansion (general-car-cdr-expansion #b11110)) +(define caadar-expansion (general-car-cdr-expansion #b11101)) +(define caaddr-expansion (general-car-cdr-expansion #b11100)) +(define cadaar-expansion (general-car-cdr-expansion #b11011)) +(define cadadr-expansion (general-car-cdr-expansion #b11010)) +(define caddar-expansion (general-car-cdr-expansion #b11001)) +(define cadddr-expansion (general-car-cdr-expansion #b11000)) +(define cdaaar-expansion (general-car-cdr-expansion #b10111)) +(define cdaadr-expansion (general-car-cdr-expansion #b10110)) +(define cdadar-expansion (general-car-cdr-expansion #b10101)) +(define cdaddr-expansion (general-car-cdr-expansion #b10100)) +(define cddaar-expansion (general-car-cdr-expansion #b10011)) +(define cddadr-expansion (general-car-cdr-expansion #b10010)) +(define cdddar-expansion (general-car-cdr-expansion #b10001)) +(define cddddr-expansion (general-car-cdr-expansion #b10000)) + +(define second-expansion cadr-expansion) +(define third-expansion caddr-expansion) +(define fourth-expansion cadddr-expansion) +(define fifth-expansion (general-car-cdr-expansion #b110000)) +(define sixth-expansion (general-car-cdr-expansion #b1100000)) +(define seventh-expansion (general-car-cdr-expansion #b11000000)) +(define eighth-expansion (general-car-cdr-expansion #b110000000)) + +;;;; Miscellaneous + +(define (make-string-expansion operands if-expanded if-not-expanded) + (let ((n (length operands))) + (cond ((zero? n) + (error "MAKE-STRING-EXPANSION: No arguments")) + ((= n 1) + (if-expanded (make-combination string-allocate operands))) + (else + (if-not-expanded))))) + +(define (identity-procedure-expansion operands if-expanded if-not-expanded) + (if (not (= (length operands) 1)) + (error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments" + (length operands))) + (if-expanded (car operands))) + +;;;; Tables + +(define usual-integrations/expansion-names + '(= < > <= >= + - * / quotient remainder + apply cons* list vector + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + second third fourth fifth sixth seventh eighth + make-string identity-procedure + )) + +(define usual-integrations/expansion-values + (list =-expansion <-expansion >-expansion <=-expansion >=-expansion + +-expansion --expansion *-expansion /-expansion + quotient-expansion remainder-expansion + apply*-expansion cons*-expansion list-expansion vector-expansion + caar-expansion cadr-expansion cdar-expansion cddr-expansion + caaar-expansion caadr-expansion cadar-expansion caddr-expansion + cdaar-expansion cdadr-expansion cddar-expansion cdddr-expansion + caaaar-expansion caaadr-expansion caadar-expansion caaddr-expansion + cadaar-expansion cadadr-expansion caddar-expansion cadddr-expansion + cdaaar-expansion cdaadr-expansion cdadar-expansion cdaddr-expansion + cddaar-expansion cddadr-expansion cdddar-expansion cddddr-expansion + second-expansion third-expansion fourth-expansion fifth-expansion + sixth-expansion seventh-expansion eighth-expansion + make-string-expansion identity-procedure-expansion + usual-integrations/expansion-values)) \ No newline at end of file diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm new file mode 100644 index 000000000..92be16c01 --- /dev/null +++ b/v7/src/sf/xform.scm @@ -0,0 +1,265 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.0 1987/03/10 13:25:33 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Transform Input Expression + +(declare (usual-integrations)) + +;;; GLOBAL-BLOCK is used to handle (USUAL-INTEGRATIONS), as follows. +;;; This declaration refers to a large group of names, which are +;;; normally defined in the global environment. Names in this group +;;; are supposed to be shadowed by top-level definitions in the user's +;;; program. + +;;; Normally we would intern the variable objects corresponding to +;;; those names in the block corresponding to the outermost +;;; environment in the user's program. However, if the user had a +;;; top-level definition which was intended to shadow one of those +;;; names, both the definition and the declaration would refer to the +;;; same variable object. So, instead we intern them in GLOBAL-BLOCK, +;;; which never has any user defined names in it. + +(define (transform/top-level expression) + (let ((block (block/make (block/make false false) false))) + (return-2 block (transform/top-level-1 block expression)))) + +(define (transform/top-level-1 block expression) + (fluid-let ((global-block + (let block/global-parent ((block block)) + (if (block/parent block) + (block/global-parent (block/parent block)) + block)))) + (let ((environment (environment/make))) + (if (scode-open-block? expression) + (open-block-components expression + (transform/open-block* block environment)) + (transform/expression block environment expression))))) + +(define (transform/expressions block environment expressions) + (map (lambda (expression) + (transform/expression block environment expression)) + expressions)) + +(define (transform/expression block environment expression) + ((transform/dispatch expression) block environment expression)) + +(define global-block) + +(define (environment/make) + '()) + +(define (environment/lookup environment name) + (let ((association (assq name environment))) + (if association + (cdr association) + (block/lookup-name global-block name)))) + +(define (environment/bind environment variables) + (map* environment + (lambda (variable) + (cons (variable/name variable) variable)) + variables)) + +(define (transform/open-block block environment expression) + (open-block-components expression + (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))) + (block/set-bound-variables! block variables) + (block/set-declarations! block (declarations/parse block declarations)) + (let ((environment (environment/bind environment variables))) + + (define (loop variables actions) + (cond ((null? variables) + (return-2 '() (map transform actions))) + ((null? actions) + (error "Extraneous auxiliaries" variables)) + + ;; Because `scan-defines' returns the auxiliary names in a + ;; particular order, we can expect to encounter them in that + ;; same order when looking through the body's actions. + + ((and (scode-assignment? (car actions)) + (eq? (assignment-name (car actions)) + (variable/name (car variables)))) + (transmit-values (loop (cdr variables) (cdr actions)) + (lambda (values actions*) + (return-2 + (cons (transform (assignment-value (car actions))) values) + (cons open-block/value-marker actions*))))) + (else + (transmit-values (loop variables (cdr actions)) + (lambda (values actions*) + (return-2 values + (cons (transform (car actions)) actions*))))))) + + (define (transform subexpression) + (transform/expression block environment subexpression)) + + (transmit-values (loop variables (sequence-actions body)) + (lambda (values actions) + (open-block/make block variables values actions)))))) + +(define (transform/variable block environment expression) + (reference/make block + (environment/lookup environment (variable-name expression)))) + +(define (transform/assignment block environment expression) + (assignment-components expression + (lambda (name value) + (assignment/make block + (environment/lookup environment name) + (transform/expression block environment value))))) + +(define (transform/lambda block environment expression) + (lambda-components* expression + (lambda (name required optional rest body) + (let ((block (block/make block true))) + (transmit-values + (let ((name->variable (lambda (name) (variable/make block name)))) + (return-4 (name->variable name) + (map name->variable required) + (map name->variable optional) + (and rest (name->variable rest)))) + (lambda (name required optional rest) + (let ((bound + `(,name ,@required ,@optional ,@(if rest `(,rest) '())))) + (block/set-bound-variables! block bound) + (procedure/make + block name required optional rest + (transform/procedure-body block + (environment/bind environment bound) + body))))))))) + +(define (transform/procedure-body block environment expression) + (if (scode-open-block? expression) + (open-block-components expression + (lambda (auxiliary declarations body) + (if (null? auxiliary) + (begin (block/set-declarations! + block + (declarations/parse block declarations)) + (transform/expression block environment body)) + (transform/open-block block environment expression)))) + (transform/expression block environment expression))) + +(define (transform/definition block environment expression) + (definition-components expression + (lambda (name value) + (error "Unscanned definition encountered. Unable to proceed." name)))) + +(define (transform/access block environment expression) + (access-components expression + (lambda (environment* name) + (access/make (transform/expression block environment environment*) + name)))) + +(define (transform/combination block environment expression) + (combination-components expression + (lambda (operator operands) + (combination/make (transform/expression block environment operator) + (transform/expressions block environment operands))))) + +(define (transform/comment block environment expression) + (transform/expression block (comment-expression environment expression))) + +(define (transform/conditional block environment expression) + (conditional-components expression + (lambda (predicate consequent alternative) + (conditional/make + (transform/expression block environment predicate) + (transform/expression block environment consequent) + (transform/expression block environment alternative))))) + +(define (transform/constant block environment expression) + (constant/make expression)) + +(define (transform/declaration block environment expression) + (declaration-components expression + (lambda (declarations expression) + (declaration/make (declarations/parse block declarations) + (transform/expression block environment expression))))) + +(define (transform/delay block environment expression) + (delay/make + (transform/expression block environment (delay-expression expression)))) + +(define (transform/disjunction block environment expression) + (disjunction-components expression + (lambda (predicate alternative) + (disjunction/make + (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))))) + +(define (transform/quotation block environment expression) + (transform/quotation* (quotation-expression expression))) + +(define (transform/quotation* expression) + (transmit-values (transform/top-level expression) + quotation/make)) + +(define (transform/sequence block environment expression) + (sequence/make + (transform/expressions block environment (sequence-actions expression)))) + +(define (transform/the-environment block environment expression) + (block/unsafe! block) + (the-environment/make block)) + +(define transform/dispatch + (make-type-dispatcher + `((,access-type ,transform/access) + (,assignment-type ,transform/assignment) + (,combination-type ,transform/combination) + (,comment-type ,transform/comment) + (,conditional-type ,transform/conditional) + (,declaration-type ,transform/declaration) + (,definition-type ,transform/definition) + (,delay-type ,transform/delay) + (,disjunction-type ,transform/disjunction) + (,in-package-type ,transform/in-package) + (,lambda-type ,transform/lambda) + (,open-block-type ,transform/open-block) + (,quotation-type ,transform/quotation) + (,sequence-type ,transform/sequence) + (,the-environment-type ,transform/the-environment) + (,variable-type ,transform/variable)) + transform/constant)) \ No newline at end of file diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm new file mode 100644 index 000000000..b4ea5b8c8 --- /dev/null +++ b/v8/src/sf/make.scm @@ -0,0 +1,107 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.0 1987/03/10 13:25:03 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: System Construction + +(in-package system-global-environment +(declare (usual-integrations)) + +(define sf) +(load "$zcomp/base/load" system-global-environment) + +(load-system system-global-environment + 'PACKAGE/BETA + '(SYSTEM-GLOBAL-ENVIRONMENT) + '( + (PACKAGE/BETA + "mvalue.bin" ;Multiple Value Support + "eqsets.bin" ;Set Data 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 + ) + + (PACKAGE/TOP-LEVEL + "toplev.bin" ;Top Level + ) + + (PACKAGE/TRANSFORM + "xform.bin" ;SCode -> Internal + ) + + (PACKAGE/INTEGRATE + "subst.bin" ;Beta Substitution Optimizer + ) + + (PACKAGE/CGEN + "cgen.bin" ;Internal -> SCode + ) + + (PACKAGE/EXPANSION + "usiexp.bin" ;Usual Integrations: Expanders + ) + + (PACKAGE/DECLARATION-PARSER + "pardec.bin" ;Declaration Parser + ) + + (PACKAGE/COPY + "copy.bin" ;Copy Expressions + ) + + (PACKAGE/FREE + "free.bin" ;Free Variable Analysis + ) + + (PACKAGE/SAFE? + "safep.bin" ;Safety Analysis + ) + + )) + +(in-package package/beta + (define beta/system + (make-environment + (define :name "Beta") + (define :version 3) + (define :modification 0))) + (add-system! beta/system) + (beta/initialize!)) + +;;; 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 new file mode 100644 index 000000000..e597ac8d6 --- /dev/null +++ b/v8/src/sf/toplev.scm @@ -0,0 +1,295 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.0 1987/03/10 13:25:25 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Optimizer: Top Level + +(declare (usual-integrations)) + +;;;; User Interface + +(define generate-unfasl-files? false + "Set this non-false to cause unfasl files to be generated by default.") + +(define optimize-open-blocks? false + "Set this non-false to eliminate unreferenced auxiliary definitions. +Currently this optimization is not implemented.") + +(define (integrate/procedure procedure declarations) + (if (compound-procedure? procedure) + (procedure-components procedure + (lambda (*lambda environment) + (scode-eval (integrate/scode *lambda declarations false) + environment))) + (error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure))) + +(define (integrate/sexp s-expression declarations receiver) + (integrate/simple phase:syntax (list s-expression) declarations receiver)) + +(define (integrate/scode scode declarations receiver) + (integrate/simple identity-procedure scode declarations receiver)) + +(define (sf input-string #!optional bin-string spec-string) + (if (unassigned? bin-string) (set! bin-string false)) + (if (unassigned? spec-string) (set! spec-string false)) + (syntax-file input-string bin-string spec-string)) + +(define (scold input-string #!optional bin-string spec-string) + "Use this only for syntaxing the cold-load root file. +Currently only the 68000 implementation needs this." + (if (unassigned? bin-string) (set! bin-string false)) + (if (unassigned? spec-string) (set! spec-string false)) + (fluid-let ((wrapping-hook wrap-with-control-point)) + (syntax-file input-string bin-string spec-string))) + +;;;; File Syntaxer + +(define sf/default-input-pathname + (make-pathname false false false "scm" 'NEWEST)) + +(define sf/default-externs-pathname + (make-pathname false false false "ext" 'NEWEST)) + +(define sf/output-pathname-type "bin") +(define sf/unfasl-pathname-type "unf") + +(define (syntax-file input-string bin-string spec-string) + (let ((eval-sf-expression + (lambda (input-string) + (let ((input-path + (pathname->input-truename + (merge-pathnames (->pathname input-string) + sf/default-input-pathname)))) + (if (not input-path) + (error "SF: File does not exist" input-string)) + (let ((bin-path + (let ((bin-path + (pathname-new-type input-path + sf/output-pathname-type))) + (if bin-string + (merge-pathnames (->pathname bin-string) bin-path) + bin-path)))) + (let ((spec-path + (and (or spec-string generate-unfasl-files?) + (let ((spec-path + (pathname-new-type bin-path + sf/unfasl-pathname-type))) + (if spec-string + (merge-pathnames (->pathname spec-string) + spec-path) + spec-path))))) + (syntax-file* input-path bin-path spec-path))))))) + (if (list? input-string) + (for-each (lambda (input-string) + (eval-sf-expression input-string)) + input-string) + (eval-sf-expression input-string))) + *the-non-printing-object*) + +(define (syntax-file* input-pathname bin-pathname spec-pathname) + (let ((start-date (date)) + (start-time (time)) + (input-filename (pathname->string input-pathname)) + (bin-filename (pathname->string bin-pathname)) + (spec-filename (and spec-pathname (pathname->string spec-pathname)))) + (newline) + (write-string "Syntax file: ") + (write input-filename) + (write-string " ") + (write bin-filename) + (write-string " ") + (write spec-filename) + (transmit-values (integrate/file input-pathname '() spec-pathname) + (lambda (expression externs events) + (fasdump (wrapping-hook + (make-comment `((SOURCE-FILE . ,input-filename) + (DATE . ,start-date) + (TIME . ,start-time) + (FLUID-LET . ,*fluid-let-type*)) + (set! expression false))) + bin-pathname) + (write-externs-file (pathname-new-type + bin-pathname + (pathname-type sf/default-externs-pathname)) + (set! externs false)) + (if spec-pathname + (begin (newline) + (write-string "Writing ") + (write spec-filename) + (with-output-to-file spec-pathname + (lambda () + (newline) + (write `(DATE ,start-date ,start-time)) + (newline) + (write `(FLUID-LET ,*fluid-let-type*)) + (newline) + (write `(SOURCE-FILE ,input-filename)) + (newline) + (write `(BINARY-FILE ,bin-filename)) + (for-each (lambda (event) + (newline) + (write `(,(car event) + (RUNTIME ,(cdr event))))) + events))) + (write-string " -- done"))))))) + +(define (read-externs-file pathname) + (fasload (merge-pathnames (->pathname pathname) + sf/default-externs-pathname))) + +(define (write-externs-file pathname externs) + (if (not (null? externs)) + (fasdump externs pathname))) + +(define (print-spec identifier names) + (newline) + (newline) + (write-string "(") + (write identifier) + (let loop + ((names + (sort names + (lambda (x y) + (stringstring x) + (symbol->string y)))))) + (if (not (null? names)) + (begin (newline) + (write (car names)) + (loop (cdr names))))) + (write-string ")")) + +(define (wrapping-hook scode) + scode) + +(define control-point-tail + `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4)) + () () () () () () () () () () () () () () ())) + +(define (wrap-with-control-point scode) + (system-list-to-vector type-code-control-point + `(,return-address-restart-execution + ,scode + ,system-global-environment + ,return-address-non-existent-continuation + ,@control-point-tail))) + +(define type-code-control-point + (microcode-type 'CONTROL-POINT)) + +(define return-address-restart-execution + (make-return-address (microcode-return 'RESTART-EXECUTION))) + +(define return-address-non-existent-continuation + (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION))) + +;;;; Optimizer Top Level + +(define (integrate/file file-name declarations compute-free?) + (integrate/kernel (lambda () + (phase:syntax (phase:read file-name))) + declarations)) + +(define (integrate/simple preprocessor input declarations receiver) + (transmit-values + (integrate/kernel (lambda () (preprocessor input)) declarations) + (or receiver + (lambda (expression externs events) + expression)))) + +(define (integrate/kernel get-scode declarations) + (fluid-let ((previous-time false) + (previous-name false) + (events '())) + (transmit-values + (transmit-values + (transmit-values + (phase:transform (canonicalize-scode (get-scode) declarations)) + phase:optimize) + phase:generate-scode) + (lambda (externs expression) + (end-phase) + (return-3 expression externs (reverse! events)))))) + +(define (canonicalize-scode scode declarations) + (let ((declarations + ((access process-declarations syntaxer-package) declarations))) + (if (null? declarations) + scode + (scan-defines (make-sequence + (list (make-block-declaration declarations) + scode)) + make-open-block)))) + +(define (phase:read filename) + (mark-phase "Read") + (read-file filename)) + +(define (phase:syntax s-expression) + (mark-phase "Syntax") + (syntax* s-expression (make-syntax-table system-global-syntax-table))) + +(define (phase:transform scode) + (mark-phase "Transform") + (transform/expression scode)) + +(define (phase:optimize block expression) + (mark-phase "Optimize") + (integrate/expression block expression)) + +(define (phase:generate-scode operations environment expression) + (mark-phase "Generate SCode") + (return-2 (operations->external operations environment) + (cgen/expression expression))) + +(define previous-time) +(define previous-name) +(define events) + +(define (mark-phase this-name) + (end-phase) + (newline) + (write-string " ") + (write-string this-name) + (write-string "...") + (set! previous-name this-name)) + +(define (end-phase) + (let ((this-time (runtime))) + (if previous-time + (let ((dt (- this-time previous-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 -- 2.25.1