From 497929ef5a8805174c08aee378d8f0412a400010 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 1 Sep 1993 00:10:47 +0000 Subject: [PATCH] Extend REPLACE-OPERATOR declaration to allow it to work on a combination whose operator is a primitive procedure. In order to do this, it was necessary to extend the COMBINATION datatype to include a BLOCK object; this change affected quite a few files. --- v7/src/sf/copy.scm | 3 +- v7/src/sf/make.scm | 4 +- v7/src/sf/object.scm | 4 +- v7/src/sf/pardec.scm | 57 ++++++++++++----- v7/src/sf/reduct.scm | 63 +++++++++---------- v7/src/sf/subst.scm | 95 ++++++++++++++++++----------- v7/src/sf/toplev.scm | 4 +- v7/src/sf/usiexp.scm | 141 +++++++++++++++++++++++-------------------- v7/src/sf/xform.scm | 3 +- v8/src/sf/make.scm | 4 +- v8/src/sf/toplev.scm | 4 +- 11 files changed, 223 insertions(+), 159 deletions(-) diff --git a/v7/src/sf/copy.scm b/v7/src/sf/copy.scm index 3fd071831..b1ad27222 100644 --- a/v7/src/sf/copy.scm +++ b/v7/src/sf/copy.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: copy.scm,v 4.3 1993/08/03 03:09:45 gjr Exp $ +$Id: copy.scm,v 4.4 1993/09/01 00:10:20 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -195,6 +195,7 @@ MIT in each case. |# (lambda (block environment expression) (combination/make (combination/scode expression) + block (copy/expression block environment (combination/operator expression)) (copy/expressions block environment (combination/operands expression))))) diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index f167be6c2..58520c0de 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 4.26 1993/01/02 07:33:35 cph Exp $ +$Id: make.scm,v 4.27 1993/09/01 00:10:47 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -39,4 +39,4 @@ MIT in each case. |# (package/system-loader "sf" '() 'QUERY) ((package/reference (find-package '(SCODE-OPTIMIZER)) 'USUAL-INTEGRATIONS/CACHE!)) -(add-system! (make-system "SF" 4 26 '())) \ No newline at end of file +(add-system! (make-system "SF" 4 27 '())) \ No newline at end of file diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm index 913af0026..d1cbb7854 100644 --- a/v7/src/sf/object.scm +++ b/v7/src/sf/object.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: object.scm,v 4.6 1993/08/03 03:09:47 gjr Exp $ +$Id: object.scm,v 4.7 1993/09/01 00:10:22 cph Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -145,7 +145,7 @@ MIT in each case. |# (define-simple-type variable (block name flags) #F) (define-simple-type access (environment name)) (define-simple-type assignment (block variable value)) - (define-simple-type combination (operator operands)) + (define-simple-type combination (block operator operands)) (define-simple-type conditional (predicate consequent alternative)) (define-simple-type constant (value)) (define-simple-type declaration (declarations expression)) diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm index 355b220f9..f64d3a1fa 100644 --- a/v7/src/sf/pardec.scm +++ b/v7/src/sf/pardec.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: pardec.scm,v 4.8 1993/08/03 22:40:23 jacob Exp $ +$Id: pardec.scm,v 4.9 1993/09/01 00:10:24 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -257,7 +257,9 @@ MIT in each case. |# (change-type/expression value) (list (make-declaration operation - (block/lookup-name block name true) + (if (symbol? name) + (block/lookup-name block name true) + name) (make-integration-info (copy/expression/extern block value)) true)))))) @@ -294,7 +296,9 @@ MIT in each case. |# (finish (integration-info/expression value))) ((dumpable-expander? value) (vector operation - (variable/name variable) + (if (variable? variable) + (variable/name variable) + variable) (dumpable-expander->dumped-expander value))) (else (error "Unrecognized extern value:" value)))))))))) @@ -339,18 +343,6 @@ MIT in each case. |# false)) reduction-rules))) -(define-declaration 'REPLACE-OPERATOR - (lambda (block replacements) - (check-declaration-syntax 'REPLACE-OPERATOR replacements) - (map (lambda (replacement) - (make-declaration 'EXPAND - (block/lookup-name block (car replacement) true) - (make-dumpable-expander - (replacement/make replacement block) - `(REPLACE-OPERATOR ,replacement)) - false)) - replacements))) - (define (check-declaration-syntax kind declarations) (if (not (and (list? declarations) (for-all? declarations @@ -360,6 +352,41 @@ MIT in each case. |# (list? (cdr declaration))))))) (error "Bad declaration:" kind declarations))) +(define-declaration 'REPLACE-OPERATOR + (lambda (block replacements) + (if (not (and (list? replacements) + (for-all? replacements + (lambda (replacement) + (and (pair? replacement) + (or (symbol? (car replacement)) + (and (pair? (car replacement)) + (eq? 'PRIMITIVE (caar replacement)) + (pair? (cdar replacement)) + (symbol? (cadar replacement)) + (or (null? (cddar replacement)) + (and (pair? (cddar replacement)) + (null? (cdddar replacement)))))) + (list? (cdr replacement))))))) + (error "Bad declaration:" 'REPLACE-OPERATOR replacements)) + (map (lambda (replacement) + (make-declaration + 'EXPAND + (let ((name (car replacement))) + (cond ((symbol? name) + (block/lookup-name block name true)) + ((and (pair? name) + (eq? (car name) 'PRIMITIVE)) + (make-primitive-procedure (cadr name) + (and (not (null? (cddr name))) + (caddr name)))) + (else + (error "Illegal name in replacement:" name)))) + (make-dumpable-expander + (replacement/make replacement block) + `(REPLACE-OPERATOR ,replacement)) + false)) + replacements))) + (define (make-dumpable-expander expander declaration) (make-entity (lambda (self expr operands if-expanded if-not-expanded block) self ; ignored diff --git a/v7/src/sf/reduct.scm b/v7/src/sf/reduct.scm index d02f6df8d..8f54cde2a 100644 --- a/v7/src/sf/reduct.scm +++ b/v7/src/sf/reduct.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: reduct.scm,v 4.7 1993/08/03 22:40:00 jacob Exp $ +$Id: reduct.scm,v 4.8 1993/09/01 00:10:25 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -239,11 +239,11 @@ Examples: (else (loop (cdr l) done))))) -(define (combine-1 unop x) - (combination/make false unop (list x))) +(define (combine-1 block unop x) + (combination/make false block unop (list x))) -(define (combine-2 binop x y) - (combination/make false binop (list x y))) +(define (combine-2 block binop x y) + (combination/make false block binop (list x y))) ;;;; Building blocks @@ -266,7 +266,7 @@ Examples: (declare (integrate mapper)) (lambda (block value combiner) combiner ; ignored - (combine-1 (mapper block) value))))) + (combine-1 block (mapper block) value))))) (define (->wrapper mapper) (handle-variable mapper @@ -274,6 +274,7 @@ Examples: (declare (integrate mapper)) (lambda (block not-reduced reduced) (combination/make false + block (mapper block) (append not-reduced (list reduced))))))) @@ -312,7 +313,7 @@ Examples: (lambda (expr) (declare (integrate expr)) (lambda (block x y) - (combine-2 (expr block) x y))))))) + (combine-2 block (expr block) x y))))))) (lambda (expr operands if-expanded if-not-expanded block) (define (group l) @@ -510,30 +511,30 @@ Examples: (define (replacement/make replacement decl-block) (call-with-values - (lambda () - (parse-replacement (car replacement) - (cdr replacement) - decl-block)) - (lambda (table default) - (lambda (expr operands if-expanded if-not-expanded block) - (let* ((len (length operands)) - (candidate (or (and (< len (vector-length table)) - (vector-ref table len)) - default))) - (if (or (not (pair? candidate)) - (and (car candidate) - (block/limited-lookup block - (car candidate) - decl-block))) - (if-not-expanded) - (if-expanded - (combination/make - (and expr (object/scode expr)) - (let ((frob (cdr candidate))) - (if (variable? frob) - (lookup (variable/name frob) block) - frob)) - operands)))))))) + (lambda () + (parse-replacement (car replacement) + (cdr replacement) + decl-block)) + (lambda (table default) + (lambda (expr operands if-expanded if-not-expanded block) + (let* ((len (length operands)) + (candidate (or (and (< len (vector-length table)) + (vector-ref table len)) + default))) + (if (or (not (pair? candidate)) + (and (car candidate) + (block/limited-lookup block + (car candidate) + decl-block))) + (if-not-expanded) + (if-expanded + (combination/make (and expr (object/scode expr)) + block + (let ((frob (cdr candidate))) + (if (variable? frob) + (lookup (variable/name frob) block) + frob)) + operands)))))))) (define (parse-replacement name ocases block) (define (collect len cases default) diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm index c9bd3a2ae..fc395d91b 100644 --- a/v7/src/sf/subst.scm +++ b/v7/src/sf/subst.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: subst.scm,v 4.10 1993/08/03 03:09:49 gjr Exp $ +$Id: subst.scm,v 4.11 1993/09/01 00:10:26 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -206,8 +206,8 @@ MIT in each case. |# ;; not found variable true))))))))) -(define (integrate/reference-operator expression operations - environment operator operands) +(define (integrate/reference-operator expression operations environment + block operator operands) (let ((variable (reference/variable operator))) (letrec ((mark-integrated! (lambda () @@ -215,13 +215,13 @@ MIT in each case. |# (integration-failure (lambda () (variable/reference! variable) - (combination/optimizing-make expression operator operands))) + (combination/optimizing-make expression block + operator operands))) (integration-success (lambda (operator) (mark-integrated!) - (integrate/combination expression - operations environment - operator operands))) + (integrate/combination expression operations environment + block operator operands))) (try-safe-integration (lambda () (integrate/name-if-safe expression operator @@ -432,47 +432,72 @@ you ask for. (lambda (operations environment combination) (integrate/combination combination operations environment + (combination/block combination) (combination/operator combination) (integrate/expressions operations environment (combination/operands combination))))) (define (integrate/combination expression operations environment - operator operands) + block operator operands) (cond ((reference? operator) (integrate/reference-operator expression operations environment - operator operands)) + block operator operands)) ((and (access? operator) (system-global-environment? (access/environment operator))) (integrate/access-operator expression operations environment - operator operands)) + block operator operands)) ((and (constant? operator) - (eq? (constant/value operator) (ucode-primitive apply)) - (integrate/hack-apply? operands)) - => (lambda (operands*) - (integrate/combination expression - operations environment - (car operands*) (cdr operands*)))) + (primitive-procedure? (constant/value operator))) + (let ((operands* + (and (eq? (constant/value operator) (ucode-primitive apply)) + (integrate/hack-apply? operands)))) + (if operands* + (integrate/combination expression operations environment + block (car operands*) (cdr operands*)) + (integrate/primitive-operator expression operations environment + block operator operands)))) (else (combination/optimizing-make expression + block (if (procedure? operator) (integrate/procedure-operator operations environment - operator operands) + block operator operands) (let ((operator (integrate/expression operations environment operator))) (if (procedure? operator) (integrate/procedure-operator operations environment - operator operands) + block operator operands) operator))) operands)))) (define (integrate/procedure-operator operations environment - procedure operands) + block procedure operands) (integrate/procedure operations - (simulate-application environment procedure operands) + (simulate-application environment block + procedure operands) procedure)) +(define (integrate/primitive-operator expression operations environment + block operator operands) + (let ((integration-failure + (lambda () + (combination/optimizing-make expression block operator operands)))) + (operations/lookup operations (constant/value operator) + (lambda (operation info) + (case operation + ((#F) (integration-failure)) + ((EXPAND) + (info expression + operands + (lambda (expression) + (integrate/expression operations environment expression)) + integration-failure + block)) + (else (error "Unknown operation" operation)))) + integration-failure))) + (define-method/integrate 'DECLARATION (lambda (operations environment declaration) (let ((declarations (declaration/declarations declaration)) @@ -483,7 +508,7 @@ you ask for. (integrate/expression (declarations/bind operations declarations) environment expression))))) - + ;;;; Easy Cases (define-method/integrate 'CONSTANT @@ -639,24 +664,22 @@ you ask for. operations environment ;ignore expression))) -(define (integrate/access-operator expression operations - environment operator operands) +(define (integrate/access-operator expression operations environment + block operator operands) (let ((name (access/name operator)) (dont-integrate (lambda () (combination/make (and expression (object/scode expression)) - operator operands)))) + block operator operands)))) (cond ((and (eq? name 'APPLY) (integrate/hack-apply? operands)) => (lambda (operands*) - (integrate/combination expression - operations environment - (car operands*) (cdr operands*)))) + (integrate/combination expression operations environment + block (car operands*) (cdr operands*)))) ((assq name usual-integrations/constant-alist) => (lambda (entry) - (integrate/combination expression - operations environment - (cdr entry) operands))) + (integrate/combination expression operations environment + block (cdr entry) operands))) ((assq name usual-integrations/expansion-alist) => (lambda (entry) ((cdr entry) expression operands @@ -766,7 +789,7 @@ you ask for. (append (except-last-pair operands) tail))))) -(define (simulate-application environment procedure operands) +(define (simulate-application environment block procedure operands) (define (procedure->pretty procedure) (if (procedure/scode procedure) (unsyntax (procedure/scode procedure)) @@ -820,7 +843,9 @@ you ask for. (let walk ((operands operands)) (if (null? operands) const-null - (combination/make false const-cons + (combination/make false + block + const-cons (list (car operands) (walk (cdr operands)))))))))) @@ -938,7 +963,7 @@ forms are simply removed. ;;; Actually, we really don't want to hack with these for various ;;; reasons -(define (combination/optimizing-make expression operator operands) +(define (combination/optimizing-make expression block operator operands) (cond ( ;; fold constants (and (foldable-operator? operator) @@ -978,6 +1003,7 @@ forms are simply removed. (reassign expression (procedure/body operator)) (combination/make (and expression (object/scode expression)) + block (procedure/make (procedure/scode operator) (procedure/block operator) @@ -994,7 +1020,7 @@ forms are simply removed. (append unreferenced-operands (list form)))))))) (else (combination/make (and expression (object/scode expression)) - operator operands)))) + block operator operands)))) (define (delete-unreferenced-parameters parameters rest body operands receiver) (let ((free-in-body (free/expression body))) @@ -1402,6 +1428,7 @@ forms are simply removed. block (combination/optimizing-make (and expression (object/scode expression)) + block (procedure/make false block diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index 1cb8d9987..a17063df9 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: toplev.scm,v 4.11 1993/08/03 02:26:28 gjr Exp $ +$Id: toplev.scm,v 4.12 1993/09/01 00:10:28 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -268,7 +268,7 @@ MIT in each case. |# (string->symbol "#[(scode-optimizer top-level)externs-file]")) (define externs-file-version - 3) + 4) ;;;; Optimizer Top Level diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index 4b36b46dd..0be9bb696 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: usiexp.scm,v 4.17 1993/08/31 20:53:51 cph Exp $ +$Id: usiexp.scm,v 4.18 1993/09/01 00:10:29 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -40,9 +40,10 @@ MIT in each case. |# ;;;; Fixed-arity arithmetic primitives -(define (make-combination expression primitive operands) +(define (make-combination expression block primitive operands) (combination/make (and expression (object/scode expression)) + block (constant/make false primitive) operands)) @@ -52,19 +53,17 @@ MIT in each case. |# (define (unary-arithmetic primitive) (lambda (expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (null? (cdr operands))) - (if-expanded (make-combination expr primitive operands)) + (if-expanded (make-combination expr block primitive operands)) (if-not-expanded)))) (define (binary-arithmetic primitive) (lambda (expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (pair? (cdr operands)) (null? (cddr operands))) - (if-expanded (make-combination expr primitive operands)) + (if-expanded (make-combination expr block primitive operands)) (if-not-expanded)))) (define zero?-expansion @@ -95,17 +94,18 @@ MIT in each case. |# (define (pairwise-test binary-predicate if-left-zero if-right-zero) (lambda (expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (pair? (cdr operands)) (null? (cddr operands))) (if-expanded (cond ((constant-eq? (car operands) 0) - (make-combination expr if-left-zero (list (cadr operands)))) + (make-combination expr block if-left-zero + (list (cadr operands)))) ((constant-eq? (cadr operands) 0) - (make-combination expr if-right-zero (list (car operands)))) + (make-combination expr block if-right-zero + (list (car operands)))) (else - (make-combination expr binary-predicate operands)))) + (make-combination expr block binary-predicate operands)))) (if-not-expanded)))) (define (pairwise-test-inverse inverse-expansion) @@ -114,7 +114,8 @@ MIT in each case. |# expr operands (lambda (expression) (if-expanded - (make-combination expr (ucode-primitive not) (list expression)))) + (make-combination expr block (ucode-primitive not) + (list expression)))) if-not-expanded block))) @@ -139,48 +140,49 @@ MIT in each case. |# ;;;; Fixnum Operations (define (fix:zero?-expansion expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (null? (cdr operands))) (if-expanded - (make-combination expr (ucode-primitive eq?) + (make-combination expr block (ucode-primitive eq?) (list (car operands) (constant/make false 0)))) (if-not-expanded))) (define (fix:=-expansion expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (pair? (cdr operands)) (null? (cddr operands))) - (if-expanded (make-combination expr (ucode-primitive eq?) operands)) + (if-expanded + (make-combination expr block (ucode-primitive eq?) operands)) (if-not-expanded))) (define char=?-expansion fix:=-expansion) (define (fix:<=-expansion expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (pair? (cdr operands)) (null? (cddr operands))) (if-expanded (make-combination expr + block (ucode-primitive not) (list (make-combination false + block (ucode-primitive greater-than-fixnum?) operands)))) (if-not-expanded))) (define (fix:>=-expansion expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (pair? (cdr operands)) (null? (cddr operands))) (if-expanded (make-combination expr + block (ucode-primitive not) (list (make-combination false + block (ucode-primitive less-than-fixnum?) operands)))) (if-not-expanded))) @@ -189,7 +191,6 @@ MIT in each case. |# (define (right-accumulation identity make-binary) (lambda (expr operands if-expanded if-not-expanded block) - block ; ignored (let ((operands (delq identity operands))) (let ((n (length operands))) (cond ((zero? n) @@ -205,6 +206,7 @@ MIT in each case. |# (if (null? rest) first (make-binary expr + block first (loop false (car rest) (cdr rest))))))) (else @@ -212,18 +214,18 @@ MIT in each case. |# (define +-expansion (right-accumulation 0 - (lambda (expr x y) + (lambda (expr block x y) (cond ((constant-eq? x 1) - (make-combination expr (ucode-primitive 1+) (list y))) + (make-combination expr block (ucode-primitive 1+) (list y))) ((constant-eq? y 1) - (make-combination expr (ucode-primitive 1+) (list x))) + (make-combination expr block (ucode-primitive 1+) (list x))) (else - (make-combination expr (ucode-primitive &+) (list x y))))))) + (make-combination expr block (ucode-primitive &+) (list x y))))))) (define *-expansion (right-accumulation 1 - (lambda (expr x y) - (make-combination expr (ucode-primitive &*) (list x y))))) + (lambda (expr block x y) + (make-combination expr block (ucode-primitive &*) (list x y))))) (define (expt-expansion expr operands if-expanded if-not-expanded block) (let ((make-binder @@ -231,13 +233,14 @@ MIT in each case. |# (if-expanded (combination/make (and expr (object/scode expr)) + block (let ((block (block/make block #t '())) (name (string->uninterned-symbol "operand"))) (let ((variable (variable/make&bind! block name))) (procedure/make #f block lambda-tag:let (list variable) '() #f - (make-body (reference/make false block variable))))) + (make-body block (reference/make false block variable))))) (list (car operands))))))) (cond ((not (and (pair? operands) (pair? (cdr operands)) @@ -249,30 +252,36 @@ MIT in each case. |# (if-expanded (car operands))) ((constant-eq? (cadr operands) 2) (make-binder - (lambda (operand) + (lambda (block operand) (make-combination #f + block (ucode-primitive &*) (list operand operand))))) ((constant-eq? (cadr operands) 3) (make-binder - (lambda (operand) + (lambda (block operand) (make-combination #f + block (ucode-primitive &*) (list operand (make-combination #f + block (ucode-primitive &*) (list operand operand))))))) ((constant-eq? (cadr operands) 4) (make-binder - (lambda (operand) + (lambda (block operand) (make-combination #f + block (ucode-primitive &*) (list (make-combination #f + block (ucode-primitive &*) (list operand operand)) (make-combination #f + block (ucode-primitive &*) (list operand operand))))))) (else @@ -285,7 +294,7 @@ MIT in each case. |# (if-expanded (if (constant-eq? y identity) x - (make-binary expr x y)))))) + (make-binary expr block x y)))))) (cond ((null? operands) (if-not-expanded)) ((null? (cdr operands)) @@ -299,54 +308,54 @@ MIT in each case. |# (define --expansion (right-accumulation-inverse 0 +-expansion - (lambda (expr x y) + (lambda (expr block x y) (if (constant-eq? y 1) - (make-combination expr (ucode-primitive -1+) (list x)) - (make-combination expr (ucode-primitive &-) (list x y)))))) + (make-combination expr block (ucode-primitive -1+) (list x)) + (make-combination expr block (ucode-primitive &-) (list x y)))))) (define /-expansion (right-accumulation-inverse 1 *-expansion - (lambda (expr x y) - (make-combination expr (ucode-primitive &/) (list x y))))) + (lambda (expr block x y) + (make-combination expr block (ucode-primitive &/) (list x y))))) ;;;; N-ary List Operations (define (apply*-expansion expr operands if-expanded if-not-expanded block) - block (if (< 1 (length operands) 10) (if-expanded (combination/make (and expr (object/scode expr)) + block (global-ref/make 'APPLY) - (list (car operands) (cons*-expansion-loop false (cdr operands))))) + (list (car operands) + (cons*-expansion-loop false block (cdr operands))))) (if-not-expanded))) (define (cons*-expansion expr operands if-expanded if-not-expanded block) - block (if (< -1 (length operands) 9) - (if-expanded (cons*-expansion-loop expr operands)) + (if-expanded (cons*-expansion-loop expr block operands)) (if-not-expanded))) -(define (cons*-expansion-loop expr rest) +(define (cons*-expansion-loop expr block rest) (if (null? (cdr rest)) (car rest) (make-combination expr + block (ucode-primitive cons) (list (car rest) - (cons*-expansion-loop false (cdr rest)))))) + (cons*-expansion-loop false block (cdr rest)))))) (define (list-expansion expr operands if-expanded if-not-expanded block) - block ; ignored (if (< (length operands) 9) - (if-expanded (list-expansion-loop expr operands)) + (if-expanded (list-expansion-loop expr block operands)) (if-not-expanded))) -(define (list-expansion-loop expr rest) +(define (list-expansion-loop expr block rest) (if (null? rest) (constant/make (and expr (object/scode expr)) '()) - (make-combination expr (ucode-primitive cons) + (make-combination expr block (ucode-primitive cons) (list (car rest) - (list-expansion-loop false (cdr rest)))))) + (list-expansion-loop false block (cdr rest)))))) (define (values-expansion expr operands if-expanded if-not-expanded block) if-not-expanded @@ -360,6 +369,7 @@ MIT in each case. |# operands))) (combination/make (and expr (object/scode expr)) + block (procedure/make false block lambda-tag:let variables '() false @@ -368,6 +378,7 @@ MIT in each case. |# (procedure/make false block lambda-tag:unnamed (list variable) '() false (combination/make false + block (reference/make false block variable) (map (lambda (variable) (reference/make false block variable)) @@ -376,13 +387,13 @@ MIT in each case. |# (define (call-with-values-expansion expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (pair? (cdr operands)) (null? (cddr operands))) (if-expanded (combination/make (and expr (object/scode expr)) - (combination/make false (car operands) '()) + block + (combination/make false block (car operands) '()) (cdr operands))) (if-not-expanded))) @@ -390,10 +401,10 @@ MIT in each case. |# (define (general-car-cdr-expansion encoding) (lambda (expr operands if-expanded if-not-expanded block) - block (if (= (length operands) 1) (if-expanded (make-combination expr + block (ucode-primitive general-car-cdr) (list (car operands) (constant/make false encoding)))) @@ -441,19 +452,18 @@ MIT in each case. |# ;;;; Miscellaneous (define (make-string-expansion expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (null? (cdr operands))) (if-expanded - (make-combination expr (ucode-primitive string-allocate) operands)) + (make-combination expr block (ucode-primitive string-allocate) + operands)) (if-not-expanded))) (define (type-test-expansion type) (lambda (expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (null? (cdr operands))) - (if-expanded (make-type-test expr type (car operands))) + (if-expanded (make-type-test expr block type (car operands))) (if-not-expanded)))) (define char?-expansion (type-test-expansion (ucode-type character))) @@ -465,41 +475,38 @@ MIT in each case. |# (define (exact-integer?-expansion expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (null? (cdr operands))) (if-expanded (make-disjunction expr - (make-type-test false (ucode-type fixnum) (car operands)) - (make-type-test false (ucode-type big-fixnum) (car operands)))) + (make-type-test false block (ucode-type fixnum) (car operands)) + (make-type-test false block (ucode-type big-fixnum) (car operands)))) (if-not-expanded))) (define (exact-rational?-expansion expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (null? (cdr operands))) (if-expanded (make-disjunction expr - (make-type-test false (ucode-type fixnum) (car operands)) - (make-type-test false (ucode-type big-fixnum) (car operands)) - (make-type-test false (ucode-type ratnum) (car operands)))) + (make-type-test false block (ucode-type fixnum) (car operands)) + (make-type-test false block (ucode-type big-fixnum) (car operands)) + (make-type-test false block (ucode-type ratnum) (car operands)))) (if-not-expanded))) (define (complex?-expansion expr operands if-expanded if-not-expanded block) - block (if (and (pair? operands) (null? (cdr operands))) (if-expanded (make-disjunction expr - (make-type-test false (ucode-type fixnum) (car operands)) - (make-type-test false (ucode-type big-fixnum) (car operands)) - (make-type-test false (ucode-type ratnum) (car operands)) - (make-type-test false (ucode-type big-flonum) (car operands)) - (make-type-test false (ucode-type recnum) (car operands)))) + (make-type-test false block (ucode-type fixnum) (car operands)) + (make-type-test false block (ucode-type big-fixnum) (car operands)) + (make-type-test false block (ucode-type ratnum) (car operands)) + (make-type-test false block (ucode-type big-flonum) (car operands)) + (make-type-test false block (ucode-type recnum) (car operands)))) (if-not-expanded))) (define (make-disjunction expr . clauses) @@ -509,8 +516,8 @@ MIT in each case. |# (disjunction/make (and expr (object/scode expr)) (car clauses) (loop (cdr clauses)))))) -(define (make-type-test expr type operand) - (make-combination expr +(define (make-type-test expr block type operand) + (make-combination expr block (ucode-primitive object-type?) (list (constant/make false type) operand))) diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm index aeebea58c..8ceb6e102 100644 --- a/v7/src/sf/xform.scm +++ b/v7/src/sf/xform.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xform.scm,v 4.5 1993/08/03 03:09:54 gjr Exp $ +$Id: xform.scm,v 4.6 1993/09/01 00:10:31 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -227,6 +227,7 @@ MIT in each case. |# (combination-components expression* (lambda (operator operands) (combination/make expression + block (transform/expression block environment operator) (transform/expressions block environment operands))))) diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm index f167be6c2..58520c0de 100644 --- a/v8/src/sf/make.scm +++ b/v8/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 4.26 1993/01/02 07:33:35 cph Exp $ +$Id: make.scm,v 4.27 1993/09/01 00:10:47 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -39,4 +39,4 @@ MIT in each case. |# (package/system-loader "sf" '() 'QUERY) ((package/reference (find-package '(SCODE-OPTIMIZER)) 'USUAL-INTEGRATIONS/CACHE!)) -(add-system! (make-system "SF" 4 26 '())) \ No newline at end of file +(add-system! (make-system "SF" 4 27 '())) \ No newline at end of file diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm index 1cb8d9987..a17063df9 100644 --- a/v8/src/sf/toplev.scm +++ b/v8/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: toplev.scm,v 4.11 1993/08/03 02:26:28 gjr Exp $ +$Id: toplev.scm,v 4.12 1993/09/01 00:10:28 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -268,7 +268,7 @@ MIT in each case. |# (string->symbol "#[(scode-optimizer top-level)externs-file]")) (define externs-file-version - 3) + 4) ;;;; Optimizer Top Level -- 2.25.1