From: Guillermo J. Rozas Date: Wed, 8 Jul 1987 04:43:50 +0000 (+0000) Subject: Add operator expanders for compiler. X-Git-Tag: 20090517-FFI~13272 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d253b1fa9bdd4af0316cf147febedb1bd1511f8e;p=mit-scheme.git Add operator expanders for compiler. --- diff --git a/v7/src/sf/copy.scm b/v7/src/sf/copy.scm index ade8f0b4c..0c31f31db 100644 --- a/v7/src/sf/copy.scm +++ b/v7/src/sf/copy.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.5 1987/05/09 00:50:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.6 1987/07/08 04:35:44 jinx Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -42,17 +42,19 @@ MIT in each case. |# (fluid-let ((root-block block) (copy/variable/free copy/variable/free/intern) (copy/declarations copy/declarations/intern)) - (copy/expression root-block - (environment/rebind block (environment/make) uninterned) - expression))) + (let ((environment (environment/rebind block (environment/make) uninterned))) + (copy/expression root-block + environment + expression)))) (define (copy/external/extern expression) (fluid-let ((root-block (block/make false false)) (copy/variable/free copy/variable/free/extern) (copy/declarations copy/declarations/extern)) - (let ((expression - (copy/expression root-block (environment/make) expression))) - (return-2 root-block expression)))) + (let ((environment (environment/make))) + (let ((expression + (copy/expression root-block environment expression))) + (return-2 root-block expression))))) (define (copy/expressions block environment expressions) (map (lambda (expression) @@ -71,10 +73,11 @@ MIT in each case. |# (define (copy/quotation quotation) (fluid-let ((root-block false)) - (let ((block (quotation/block quotation))) + (let ((block (quotation/block quotation)) + (environment (environment/make))) (quotation/make block (copy/expression block - (environment/make) + environment (quotation/expression quotation)))))) (define (copy/block parent environment block) @@ -121,7 +124,7 @@ MIT in each case. |# (define (copy/variable/free/extern variable) (lambda () - (block/lookup-name root-block (variable/name variable)))) + (block/lookup-name root-block (variable/name variable) true))) (define copy/declarations) @@ -144,7 +147,7 @@ MIT in each case. |# identity-procedure (lambda () (block/lookup-name root-block - (variable/name variable))))) + (variable/name variable) true)))) (lambda (expression) (copy/expression block environment expression))))) @@ -164,7 +167,7 @@ MIT in each case. |# (environment/bind environment variables (map (lambda (variable) - (block/lookup-name block (variable/name variable))) + (block/lookup-name block (variable/name variable) true)) variables))) (define (make-renamer environment) diff --git a/v7/src/sf/emodel.scm b/v7/src/sf/emodel.scm index 2032dab2c..279792dda 100644 --- a/v7/src/sf/emodel.scm +++ b/v7/src/sf/emodel.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.2 1987/03/13 04:12:19 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.3 1987/07/08 04:39:27 jinx Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -45,15 +45,17 @@ MIT in each case. |# (if (block/parent block) (block/unsafe! (block/parent block)))))) -(define (block/lookup-name block name) +(define (block/lookup-name block name intern?) (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)))))) + (cond ((not (null? parent)) + (search parent)) + (intern? + (variable/make&bind! block name)) + (else #f)))))) -(define (block/lookup-names block names) +(define (block/lookup-names block names intern?) (map (lambda (name) - (block/lookup-name block name)) + (block/lookup-name block name intern?)) names)) \ No newline at end of file diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index 1d649eec9..a3a572f3d 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.10 1987/06/30 21:48:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.11 1987/07/08 04:42:25 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -58,9 +58,9 @@ MIT in each case. |# (define scode-optimizer/system (make-environment - (define :name "SF") + (define :name "xSF") (define :version 3) - (define :modification 10) + (define :modification 10.1) (define :files) (define :files-lists diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm index 941a330d4..2f3a27d00 100644 --- a/v7/src/sf/pardec.scm +++ b/v7/src/sf/pardec.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.4 1987/05/08 02:34:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.5 1987/07/08 04:42:52 jinx Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -69,7 +69,9 @@ MIT in each case. |# (lambda (bindings global? operation export? names values) (let ((result (binding/make global? operation export? - (if global? names (block/lookup-names block names)) + (if global? + names + (block/lookup-names block names true)) values))) (transmit-values bindings (lambda (before after) @@ -77,10 +79,18 @@ MIT in each case. |# (return-2 (cons result before) after) (return-2 before (cons result after)))))))) +(declare (integrate-operator bind/general bind/values bind/no-values)) + +(define (bind/general table/cons table global? operation export? names values) + (declare (integrate table/cons table global? operation export? names values)) + (table/cons table global? operation export? names values)) + (define (bind/values table/cons table operation export? names values) + (declare (integrate table/cons table operation export? names values)) (table/cons table (not export?) operation export? names values)) (define (bind/no-values table/cons table operation export? names) + (declare (integrate table/cons table operation export? names)) (table/cons table false operation export? names 'NO-VALUES)) (define (declarations/known? declaration) @@ -306,4 +316,19 @@ MIT in each case. |# (transmit-values info (lambda (value uninterned) (finish value))) - (variable/final-value variable environment finish if-not)))))) \ No newline at end of file + (variable/final-value variable environment finish if-not)))))) + +;;;; User provided expansions and processors + +(define expander-evaluation-environment + (access package/expansion + package/scode-optimizer)) + +(define-declaration 'EXPAND-OPERATOR true + (lambda (block table/cons table expanders) + (bind/general table/cons table false 'EXPAND false + (map car expanders) + (map (lambda (expander) + (eval (cadr expander) + expander-evaluation-environment)) + expanders)))) \ No newline at end of file diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm index 06d78ef85..c3c01584e 100644 --- a/v7/src/sf/subst.scm +++ b/v7/src/sf/subst.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.5 1987/05/08 02:33:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.6 1987/07/08 04:43:11 jinx Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,28 +36,34 @@ MIT in each case. |# (declare (usual-integrations)) +(define *top-level-block*) + +(define (integrate/get-top-level-block) + *top-level-block*) + (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)))))) + (fluid-let ((*top-level-block* block)) + (let ((operations (operations/bind-block (operations/make) block)) + (environment (environment/make))) + (if (open-block? expression) + (transmit-values + (environment/recursive-bind operations environment + (open-block/variables expression) + (open-block/values expression)) + (lambda (environment values) + (return-3 operations + environment + (quotation/make block + (integrate/open-block operations + environment + expression + values))))) + (return-3 operations + environment + (quotation/make block + (integrate/expression operations + environment + expression))))))) (define (operations/bind-block operations block) (let ((declarations (block/declarations block))) @@ -115,8 +121,10 @@ MIT in each case. |# dont-integrate)) ((EXPAND) (info operands - identity-procedure ;expanded value can't be optimized further. - dont-integrate)) + (lambda (new-expression) + (integrate/expression operations environment new-expression)) + dont-integrate + (reference/block operator))) (else (error "Unknown operation" operation)))) dont-integrate))) @@ -295,7 +303,8 @@ MIT in each case. |# (integrate/combination operations environment (cdr entry) operands) (let ((entry (assq name usual-integrations/expansion-alist))) (if entry - ((cdr entry) operands identity-procedure dont-integrate) + ((cdr entry) operands identity-procedure + dont-integrate false) (dont-integrate))))))) (define (system-global-environment? expression) diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index f93c37127..9efd5f499 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.3 1987/05/09 20:30:12 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.4 1987/07/08 04:43:33 jinx Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -46,7 +46,7 @@ MIT in each case. |# (eq? (constant/value expression) constant))) (define (pairwise-test binary-predicate if-left-zero if-right-zero) - (lambda (operands if-expanded if-not-expanded) + (lambda (operands if-expanded if-not-expanded block) (cond ((or (null? operands) (null? (cdr operands))) (error "Too few operands" operands)) @@ -62,11 +62,12 @@ MIT in each case. |# (if-not-expanded))))) (define (pairwise-test-inverse inverse-expansion) - (lambda (operands if-expanded if-not-expanded) + (lambda (operands if-expanded if-not-expanded block) (inverse-expansion operands (lambda (expression) (if-expanded (make-combination not (list expression)))) - if-not-expanded))) + if-not-expanded + block))) (define =-expansion (pairwise-test (make-primitive-procedure '&=) zero? zero?)) @@ -86,7 +87,7 @@ MIT in each case. |# ;;;; N-ary Arithmetic Field Operations (define (right-accumulation identity make-binary) - (lambda (operands if-expanded if-not-expanded) + (lambda (operands if-expanded if-not-expanded block) (let ((operands (delq identity operands))) (let ((n (length operands))) (cond ((zero? n) @@ -118,7 +119,7 @@ MIT in each case. |# (make-combination &* (list x y)))))) (define (right-accumulation-inverse identity inverse-expansion make-binary) - (lambda (operands if-expanded if-not-expanded) + (lambda (operands if-expanded if-not-expanded block) (let ((expand (lambda (x y) (if-expanded @@ -133,7 +134,8 @@ MIT in each case. |# (inverse-expansion (cdr operands) (lambda (expression) (expand (car operands) expression)) - if-not-expanded)))))) + if-not-expanded + block)))))) (define --expansion (right-accumulation-inverse 0 +-expansion @@ -152,7 +154,7 @@ MIT in each case. |# ;;;; Miscellaneous Arithmetic (define (divide-component-expansion divide selector) - (lambda (operands if-expanded if-not-expanded) + (lambda (operands if-expanded if-not-expanded block) (if-expanded (make-combination selector (list (make-combination divide operands)))))) @@ -173,7 +175,7 @@ MIT in each case. |# (define apply*-expansion (let ((apply-primitive (make-primitive-procedure 'APPLY))) - (lambda (operands if-expanded if-not-expanded) + (lambda (operands if-expanded if-not-expanded block) (let ((n (length operands))) (cond ((< n 2) (error "APPLY*-EXPANSION: Too few arguments" n)) ((< n 10) @@ -184,7 +186,7 @@ MIT in each case. |# (cons*-expansion-loop (cdr operands)))))) (else (if-not-expanded))))))) -(define (cons*-expansion operands if-expanded if-not-expanded) +(define (cons*-expansion operands if-expanded if-not-expanded block) (let ((n (length operands))) (cond ((zero? n) (error "CONS*-EXPANSION: No arguments!")) ((< n 9) (if-expanded (cons*-expansion-loop operands))) @@ -197,12 +199,12 @@ MIT in each case. |# (list (car rest) (cons*-expansion-loop (cdr rest)))))) -(define (list-expansion operands if-expanded if-not-expanded) +(define (list-expansion operands if-expanded if-not-expanded block) (if (< (length operands) 9) (if-expanded (list-expansion-loop operands)) (if-not-expanded))) -(define (vector-expansion operands if-expanded if-not-expanded) +(define (vector-expansion operands if-expanded if-not-expanded block) (if (< (length operands) 9) (if-expanded (make-combination list->vector (list (list-expansion-loop operands)))) @@ -218,7 +220,7 @@ MIT in each case. |# ;;;; General CAR/CDR Encodings (define (general-car-cdr-expansion encoding) - (lambda (operands if-expanded if-not-expanded) + (lambda (operands if-expanded if-not-expanded block) (if (= (length operands) 1) (if-expanded (make-combination general-car-cdr @@ -267,7 +269,7 @@ MIT in each case. |# ;;;; Miscellaneous -(define (make-string-expansion operands if-expanded if-not-expanded) +(define (make-string-expansion operands if-expanded if-not-expanded block) (let ((n (length operands))) (cond ((zero? n) (error "MAKE-STRING-EXPANSION: No arguments")) @@ -276,7 +278,8 @@ MIT in each case. |# (else (if-not-expanded))))) -(define (identity-procedure-expansion operands if-expanded if-not-expanded) +(define (identity-procedure-expansion operands if-expanded if-not-expanded + block) (if (not (= (length operands) 1)) (error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments" (length operands))) @@ -316,4 +319,19 @@ MIT in each case. |# (define usual-integrations/expansion-alist (map cons usual-integrations/expansion-names - usual-integrations/expansion-values)) \ No newline at end of file + usual-integrations/expansion-values)) + +;;; Scode->Scode expanders + +(define (scode->scode-expander scode-expander) + (lambda (operands if-expanded if-not-expanded block) + (scode-expander + (map (access cgen/external-with-declarations package/cgen) + operands) + (lambda (scode-expression) + (if-expanded + (transform/recursive + block + (integrate/get-top-level-block) + scode-expression))) + if-not-expanded))) \ No newline at end of file diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm index 1c4eeb992..7e6d2c4dc 100644 --- a/v7/src/sf/xform.scm +++ b/v7/src/sf/xform.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.4 1987/06/05 21:36:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.5 1987/07/08 04:43:50 jinx Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -50,21 +50,32 @@ MIT in each case. |# ;;; 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 try-deep-lookup?) -(define (transform/top-level-1 block expression) - (fluid-let ((global-block - (let block/global-parent ((block block)) +(define (transform/top-level expression) + (fluid-let ((try-deep-lookup? false)) + (let ((block (block/make (block/make false false) false))) + (return-2 block (transform/top-level-1 true block block expression))))) + +(define (transform/recursive block top-level-block expression) + (fluid-let ((try-deep-lookup? true)) + (transform/top-level-1 false block top-level-block expression))) + +(define (transform/top-level-1 top-level? block top-level-block expression) + (fluid-let ((try-deep-lookup? (not top-level?)) + (global-block + (let block/global-parent ((block top-level-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))))) + (cond ((not (scode-open-block? expression)) + (transform/expression block environment expression)) + ((not top-level?) + (error "transform/top-level-1: open blocks disallowed" expression)) + (else + (open-block-components expression + (transform/open-block* block environment))))))) (define (transform/expressions block environment expressions) (map (lambda (expression) @@ -79,11 +90,12 @@ MIT in each case. |# (define (environment/make) '()) -(define (environment/lookup environment name) +(define (environment/lookup block environment name) (let ((association (assq name environment))) - (if association - (cdr association) - (block/lookup-name global-block name)))) + (cond (association (cdr association)) + ((and try-deep-lookup? + (block/lookup-name block name false))) + (else (block/lookup-name global-block name true))))) (define (environment/bind environment variables) (map* environment @@ -136,13 +148,13 @@ MIT in each case. |# (define (transform/variable block environment expression) (reference/make block - (environment/lookup environment (variable-name expression)))) + (environment/lookup block environment (variable-name expression)))) (define (transform/assignment block environment expression) (assignment-components expression (lambda (name value) (assignment/make block - (environment/lookup environment name) + (environment/lookup block environment name) (transform/expression block environment value))))) (define (transform/lambda block environment expression) @@ -155,12 +167,13 @@ MIT in each case. |# (map name->variable optional) (and rest (name->variable rest)))) (lambda (required optional rest) - (let ((bound `(,@required ,@optional ,@(if rest `(,rest) '())))) + (let* ((bound `(,@required ,@optional ,@(if rest `(,rest) '()))) + (environment (environment/bind environment bound))) (block/set-bound-variables! block bound) (procedure/make block name required optional rest (transform/procedure-body block - (environment/bind environment bound) + environment body))))))))) (define (transform/procedure-body block environment expression) diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm index 489177a2c..1b09bd43a 100644 --- a/v8/src/sf/make.scm +++ b/v8/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.10 1987/06/30 21:48:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.11 1987/07/08 04:42:25 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -58,9 +58,9 @@ MIT in each case. |# (define scode-optimizer/system (make-environment - (define :name "SF") + (define :name "xSF") (define :version 3) - (define :modification 10) + (define :modification 10.1) (define :files) (define :files-lists