From d5ee6911e77ba34d6eeca65ca027718946da8c7a Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 4 Nov 1992 10:17:40 +0000 Subject: [PATCH] Fix bugs in the implementation of REDUCE-OPERATOR and extend capabilities so that all the optimizations performed by USUAL-INTEGRATIONS can be expressed as declarations. --- v7/src/sf/make.scm | 6 +- v7/src/sf/object.scm | 18 +- v7/src/sf/pardec.scm | 149 +++++++++--- v7/src/sf/reduct.scm | 314 ++++++++++++++++++------ v7/src/sf/sf.pkg | 9 +- v7/src/sf/subst.scm | 565 ++++++++++++++++++++++++------------------- v7/src/sf/toplev.scm | 9 +- v7/src/sf/usiexp.scm | 8 +- v8/src/sf/make.scm | 6 +- v8/src/sf/toplev.scm | 9 +- 10 files changed, 719 insertions(+), 374 deletions(-) diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index c84964aa4..13523cc2a 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.23 1992/02/08 15:10:16 cph Exp $ +$Id: make.scm,v 4.24 1992/11/04 10:17:31 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -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 23 '())) \ No newline at end of file +(add-system! (make-system "SF" 4 24 '())) \ No newline at end of file diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm index d18598e4f..0aa24d5c9 100644 --- a/v7/src/sf/object.scm +++ b/v7/src/sf/object.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 4.2 1989/04/18 16:32:34 cph Rel $ +$Id: object.scm,v 4.3 1992/11/04 10:17:32 jinx Exp $ -Copyright (c) 1987, 1989 Massachusetts Institute of Technology +Copyright (c) 1987-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Data Types +;;; package: (scode-optimizer) (declare (usual-integrations) (automagic-integrations) @@ -232,9 +233,22 @@ MIT in each case. |# ;;; end LET-SYNTAX ) +(define-integrable (global-ref/make name) + ;; system-global-environment = () + (access/make (constant/make '()) name)) + +(define (global-ref? obj) + (and (access? obj) + (constant? (access/environment obj)) + (eq? (constant/value (access/environment obj)) '()) + (access/name obj))) + (define-integrable (constant->integration-info constant) (make-integration-info (constant/make constant) '())) +(define-integrable (integration-info? obj) + (pair? obj)) + (define-integrable (make-integration-info expression uninterned-variables) (cons expression uninterned-variables)) diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm index 1fa15dd61..6d5aef600 100644 --- a/v7/src/sf/pardec.scm +++ b/v7/src/sf/pardec.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 4.5 1991/10/30 21:01:22 cph Exp $ +$Id: pardec.scm,v 4.6 1992/11/04 10:17:33 jinx Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Parse Declarations +;;; package: (scode-optimizer declarations) (declare (usual-integrations) (open-block-optimizations) @@ -47,27 +48,30 @@ MIT in each case. |# (let ((bindings (accumulate (lambda (bindings declaration) - (let ((association (assq (car declaration) known-declarations))) - (if (not association) - bindings - (let ((before-bindings? (car (cdr association))) - (parser (cdr (cdr association)))) - (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))))))) + (parse-declaration block bindings/cons bindings declaration)) (cons '() '()) declarations))) (declarations/make declarations (car bindings) (cdr bindings)))) +(define (parse-declaration block table/conser bindings declaration) + (let ((association (assq (car declaration) known-declarations))) + (if (not association) + bindings + (let ((before-bindings? (car (cdr association))) + (parser (cdr (cdr association)))) + (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 + (table/conser block before-bindings?) + bindings + (cdr declaration))))))) + (define (bindings/cons block before-bindings?) (lambda (bindings global? operation export? names values) (let ((result @@ -294,18 +298,45 @@ symbol ; obvious. (define-declaration 'INTEGRATE-EXTERNAL true (lambda (block table/cons table specifications) - block ;ignored (accumulate (lambda (table extern) - (bind/values table/cons table (vector-ref extern 1) false - (list (vector-ref extern 0)) - (list - (intern-type (vector-ref extern 2) - (vector-ref extern 3))))) + (let ((operation (vector-ref extern 1)) + (vref2 (vector-ref extern 2)) + (vref3 (vector-ref extern 3))) + (if (and (eq? operation 'EXPAND) + (eq? vref2 '*DUMPED-EXPANDER*)) + (parse-declaration + block + (lambda (block before-bindings?) + block ; ignored + (if before-bindings? + (warn "INTEGRATE-EXTERNAL: before-bindings expander" + (car vref3))) + table/cons) + table + vref3) + (bind/general table/cons table true + operation false + (list (vector-ref extern 0)) + (list (intern-type vref2 vref3)))))) table (append-map! read-externs-file (append-map! specification->pathnames specifications))))) +(define-declaration 'INTEGRATE-SAFELY false + (lambda (block table/cons table names) + block ;ignored + (bind/no-values table/cons table 'INTEGRATE-SAFELY true names))) + +(define-declaration 'IGNORE false + (lambda (block table/cons table names) + (declare (ignore table/cons)) + (for-each (lambda (var) + (and var + (variable/can-ignore! var))) + (block/lookup-names block names false)) + table)) + (define (specification->pathnames specification) (let ((value (scode-eval (syntax specification system-global-syntax-table) @@ -325,25 +356,73 @@ symbol ; obvious. (vector (variable/name variable) operation block - expression))))))) - (if info - (finish (integration-info/expression info)) - (variable/final-value variable environment finish if-not)))))) + expression)))))) + (fail + (lambda () + (error "operations->external: Unrecognized processor" info)))) + + (cond ((not info) + (variable/final-value variable environment finish if-not)) + ((integration-info? info) + (finish (integration-info/expression info))) + ((entity? info) + (let ((xtra (entity-extra info))) + (if (or (not (pair? xtra)) + (not (eq? '*DUMPABLE-EXPANDER* (car xtra)))) + (fail)) + (if-ok + (vector (variable/name variable) + operation + '*DUMPED-EXPANDER* + (cdr xtra))))) + (else + (fail))))))) -;;;; User provided reductions and expansions - -;;; Reductions. See reduct.scm for a description. +;;;; User provided reductions and expansions. +;; See reduct.scm for description of REDUCE-OPERATOR and REPLACE-OPERATOR. (define-declaration 'REDUCE-OPERATOR false (lambda (block table/cons table reduction-rules) block ;ignored - ;; Maybe it wants to be exported? - (bind/general table/cons table false 'EXPAND false + (check-declaration-syntax 'REDUCE-OPERATOR reduction-rules) + (bind/general table/cons table false 'EXPAND true (map car reduction-rules) (map (lambda (rule) - (reducer/make rule block)) + (dumpable-expander + 'REDUCE-OPERATOR + rule + (reducer/make rule block))) reduction-rules)))) +(define-declaration 'REPLACE-OPERATOR false + (lambda (block table/cons table replacements) + block + (check-declaration-syntax 'REPLACE-OPERATOR replacements) + (bind/general table/cons table false 'EXPAND true + (map car replacements) + (map (lambda (replacement) + (dumpable-expander + 'REPLACE-OPERATOR + replacement + (replacement/make replacement block))) + replacements)))) + +(define (dumpable-expander declaration text expander) + (make-entity (lambda (self operands if-expanded if-not-expanded block) + self ; ignored + (expander operands if-expanded if-not-expanded block)) + (cons '*DUMPABLE-EXPANDER* + (list declaration text)))) + +(define (check-declaration-syntax kind decls) + (if (or (not (list? decls)) + (there-exists? decls + (lambda (decl) + (or (not (pair? decl)) + (not (list? (cdr decl))) + (not (symbol? (car decl))))))) + (error "Bad declaration" kind decls))) + ;;; Expansions. These should be used with great care, and require ;;; knowing a fair amount about the internals of sf. This declaration ;;; is purely a hook, with no convenience. diff --git a/v7/src/sf/reduct.scm b/v7/src/sf/reduct.scm index c8ec9fcca..029fc708a 100644 --- a/v7/src/sf/reduct.scm +++ b/v7/src/sf/reduct.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/reduct.scm,v 4.2 1991/07/19 03:45:52 cph Exp $ +$Id: reduct.scm,v 4.3 1992/11/04 10:17:34 jinx Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: User defined reductions +;;; package: (scode-optimizer expansion) (declare (usual-integrations) (automagic-integrations) @@ -40,29 +41,56 @@ MIT in each case. |# (eta-substitution) (integrate-external "object")) -;;;; Reductions +;;;; Reductions and replacements #| +REPLACE-OPERATOR declaration + +Generates SF-time expanders (transformers for sf) for operations +that act differently depending on the number of arguments. + +(replace-operator ( ( ) ( ) ...)) + + is a symbol + is a non-negative integer or one of the symbols ANY, ELSE, and OTHERWISE. + is a simple expression: + ; means a variable + (QUOTE ) = ' ; means a constant + (PRIMITIVE { }) ; means a primitive + (GLOBAL ) ; means a global variable + +replaces non-shadowed calls to with arguments +with a call to with the same arguments. + +Examples: + +(replace-operator (map (2 map-2) (3 map-3))) + +replaces (map f l) with (map-2 f l) +and (map (lambda (x) (car x)) (frob l)) +with (map-3 (lambda (x) (car x)) (frob l)) +|# + +#| REDUCE-OPERATOR declaration -Generates syntax time expanders (transformers for sf) for operations +Generates SF-time expanders (transformers for sf) for operations obtained by REDUCEing a binary operator. (reduce-operator ( { (group ) (null-value ) (singleton ) - (wrapper ) + (wrapper {}) + (maximum ) })) is a symbol -, , , and are simple expressions -(currently not checked): - ' - - (primitive { }) + and are non-negative integers. + +, , , and are simple expressions as above. is a member of {ALWAYS, ANY, ONE, SINGLE, NONE, EMPTY} @@ -97,14 +125,28 @@ which can only take the value NONE. 6) The wrapper option specifies a function, , to be invoked on the result of the outermost call to after the expansion. +If is provided it must be a non-negative integer indicating a number +of arguments that are transferred verbatim from the original call to +the wrapper. They are passed to the left of the reduction. + +7) The maximum option specifies that calls with more than arguments +should not be reduced. Examples: (declare (reduce-operator - (CONS* (primitive cons)) - (LIST (primitive cons) (NULL-VALUE '() ANY)) + (CONS* (PRIMITIVE cons)) + (LIST (PRIMITIVE cons) + (NULL-VALUE '() ANY)) (+ %+ (NULL-VALUE 0 NONE) (GROUP RIGHT)) - (- %- (NULL-VALUE 0 SINGLE) (GROUP LEFT)))) + (- %- (NULL-VALUE 0 SINGLE) (GROUP LEFT)) + (VECTOR (PRIMITIVE cons) + (GROUP RIGHT) + (NULL-VALUE '() ALWAYS) + (WRAPPER list->vector)) + (APPLY (PRIMITIVE cons) + (GROUP RIGHT) + (WRAPPER (GLOBAL apply) 1)))) |# @@ -129,10 +171,7 @@ Examples: (or (block/lookup-name block name false) (block/lookup-name (integrate/get-top-level-block) name true)))) -(declare (integrate-operator handle-variable)) - -(define (handle-variable object core) - (declare (integrate object core)) +(define-integrable (handle-variable object core) (if (variable? object) (let ((name (variable/name object))) (core (lambda (block) @@ -142,25 +181,40 @@ Examples: block ; ignore object)))) -(define (->expression exp block) +(define (->expression procedure exp block) + (define (fail) + (error "Bad primitive expression" procedure exp)) + + (define-integrable (constant value) + (constant/make value)) + (cond ((symbol? exp) (variable/make block exp '())) ((not (pair? exp)) - (constant/make exp)) + (constant exp)) ((eq? (car exp) 'PRIMITIVE) (cond ((or (null? (cdr exp)) (not (list? exp))) - (error "MAKE-REDUCER: Bad PRIMITIVE expression" exp)) + (fail)) ((null? (cddr exp)) - (constant/make (make-primitive-procedure (cadr exp)))) + (constant (make-primitive-procedure (cadr exp)))) ((null? (cdddr exp)) - (constant/make + (constant (make-primitive-procedure (cadr exp) (caddr exp)))) (else - (error "MAKE-REDUCER: Bad PRIMITIVE expression" exp)))) + (fail)))) ((eq? (car exp) 'QUOTE) - (cadr exp)) + (if (or (not (pair? (cdr exp))) + (not (null? (cddr exp)))) + (fail)) + (constant (cadr exp))) + ((eq? (car exp) 'GLOBAL) + (if (or (not (pair? (cdr exp))) + (not (null? (cddr exp))) + (not (symbol? (cadr exp)))) + (fail)) + (global-ref/make (cadr exp))) (else - (error "MAKE-REDUCER: Bad expression" exp)))) + (fail)))) ;; any-shadowed? prevents reductions in any environment where any of ;; the names introduced by the reduction has been shadowed. The @@ -210,7 +264,7 @@ Examples: (lambda (null) (declare (integrate null)) (lambda (block value combiner) - (combiner value (null block)))))) + (combiner block value (null block)))))) (define (->mapper-combiner mapper) (handle-variable mapper @@ -224,11 +278,13 @@ Examples: (handle-variable mapper (lambda (mapper) (declare (integrate mapper)) - (lambda (block reduced) - (combine-1 (mapper block) reduced))))) + (lambda (block not-reduced reduced) + (combination/make (mapper block) + (append not-reduced + (list reduced))))))) -(define (identity-wrapper block reduced) - block ; ignored +(define (identity-wrapper block not-reduced reduced) + block not-reduced ; ignored reduced) (define (->error-thunk name) @@ -249,9 +305,11 @@ Examples: ;;;; Groupers -(define (make-grouper map1 map2 binop source-block exprs +(define (make-grouper spare-args min-args max-args + map1 map2 + binop source-block exprs wrap last single none) - (let ((expr (->expression binop source-block))) + (let ((expr (->expression 'REDUCE-OPERATOR binop source-block))) (let ((vars (filter-vars (cons expr exprs))) (binop (map1 (handle-variable @@ -269,38 +327,50 @@ Examples: (car l) (group (cdr l))))) - (if (any-shadowed? vars source-block block) + (if (or (any-shadowed? vars source-block block) + (let ((l (length operands))) + (or (< l min-args) + (and max-args (> l max-args))))) (if-not-expanded) (if-expanded - (let ((l (map2 operands))) - (cond ((null? l) - (none block)) - ((null? (cdr l)) + (let ((l1 (list-head operands spare-args)) + (l2 (map2 (list-tail operands spare-args)))) + (cond ((null? l2) + (wrap block + l1 + (none block))) + ((null? (cdr l2)) (wrap block + l1 (single block - (car l) - (lambda (x y) + (car l2) + (lambda (block x y) (binop block x y))))) (else - (wrap block (binop block (car l) - (group (cdr l))))))))))))) - -(define (group-right binop source-block exprs wrap last single none) - (make-grouper identity-procedure identity-procedure binop - source-block exprs wrap - last single none)) - -(define (group-left binop source-block exprs wrap last single none) - (make-grouper invert reverse binop - source-block exprs wrap - last single none)) + (wrap block + l1 + (binop block (car l2) + (group (cdr l2))))))))))))) + +(define (group-right spare-args min-args max-args + binop source-block exprs + wrap last single none) + (make-grouper spare-args min-args max-args + identity-procedure identity-procedure + binop source-block exprs + wrap last single none)) + +(define (group-left spare-args min-args max-args + binop source-block exprs + wrap last single none) + (make-grouper spare-args min-args max-args + invert reverse + binop source-block exprs + wrap last single none)) ;;;; Keyword and convenience utilities -(declare (integrate-operator with-arguments-from)) - -(define (with-arguments-from list procedure) - (declare (integrate list procedure)) +(define-integrable (with-arguments-from list procedure) (apply procedure list)) ;;; Keyword decoder @@ -311,7 +381,7 @@ Examples: '() (cons (let ((place (assq (car keys) options))) - (if (null? place) + (if (not place) '() (cdr place))) (collect (cdr keys))))) @@ -334,18 +404,22 @@ Examples: ;;;; Error and indentation utilities (define (fail name value) - (error "MAKE-REDUCER: Bad option" `(,name ,@value))) + (error "REDUCE-OPERATOR: Bad option" `(,name ,@value))) (define (incompatible name1 val1 name2 val2) - (error "MAKE-REDUCER: Incompatible options" + (error "REDUCE-OPERATOR: Incompatible options" `(,name1 ,val1) `(,name2 ,val2))) (define (with-wrapper wrapper block receiver) (cond ((not wrapper) - (receiver identity-wrapper '())) + (receiver 0 identity-wrapper '())) ((null? (cdr wrapper)) - (let ((expr (->expression (car wrapper) block))) - (receiver (->wrapper expr) (list expr)))) + (let ((expr (->expression 'REDUCE-OPERATOR (car wrapper) block))) + (receiver 0 (->wrapper expr) (list expr)))) + ((and (null? (cddr wrapper)) + (exact-nonnegative-integer? (cadr wrapper))) + (let ((expr (->expression 'REDUCE-OPERATOR (car wrapper) block))) + (receiver (cadr wrapper) (->wrapper expr) (list expr)))) (else (fail 'WRAPPER wrapper)))) @@ -353,42 +427,52 @@ Examples: (cond ((not singleton) (receiver identity-combiner '())) ((null? (cdr singleton)) - (let ((expr (->expression (car singleton) block))) + (let ((expr (->expression 'REDUCE-OPERATOR (car singleton) block))) (receiver (->mapper-combiner expr) (list expr)))) (else (fail 'SINGLETON singleton)))) -;;;; Top level +;;;; Reduction top level (define (reducer/make rule block) (with-arguments-from rule (lambda (name binop . options) - (decode-options - '(NULL-VALUE GROUP SINGLETON WRAPPER) + (decode-options '(NULL-VALUE GROUP SINGLETON WRAPPER MAXIMUM) options - (lambda (null-value group singleton wrapper) + (lambda (null-value group singleton wrapper maximum) (define (make-reducer-internal grouper) (with-wrapper wrapper block - (lambda (wrap wrap-expr) + (lambda (spare-args wrap wrap-expr) (with-singleton singleton block (lambda (single-combiner single-expr) - (define (invoke null-expr last single none) - (grouper binop block - (append null-expr wrap-expr single-expr) - wrap last single none)) + (define (invoke min-args null-expr last single none) + (let ((max-args + (and maximum + (if (or (not (null? (cdr maximum))) + (not (exact-nonnegative-integer? + (car maximum)))) + (fail 'MAXIMUM maximum) + (car maximum))))) + (grouper spare-args min-args max-args + binop block + (append null-expr wrap-expr single-expr) + wrap last single none))) (cond ((not null-value) - (invoke '() single-combiner + (invoke (+ spare-args (if singleton 1 2)) + '() single-combiner single-combiner (->error-thunk name))) ((not (= (length null-value) 2)) (fail 'NULL-VALUE null-value)) (else - (let* ((val (->expression (car null-value) block)) + (let* ((val (->expression 'REDUCE-OPERATOR + (car null-value) + block)) (combiner (->singleton-combiner val)) (null (->value-thunk val))) (case (cadr null-value) @@ -396,16 +480,18 @@ Examples: (if singleton (incompatible 'SINGLETON singleton 'NULL-VALUE null-value)) - (invoke (list val) combiner + (invoke spare-args (list val) combiner combiner null)) ((ONE SINGLE) (if singleton (incompatible 'SINGLETON singleton 'NULL-VALUE null-value)) - (invoke (list val) identity-combiner + (invoke (1+ spare-args) (list val) + identity-combiner combiner null)) ((NONE EMPTY) - (invoke (list val) single-combiner + (invoke spare-args + (list val) single-combiner single-combiner null)) (else (fail 'NULL-VALUE null-value))))))))))) @@ -423,6 +509,82 @@ Examples: (else (fail 'GROUP group)))))))))) +;;;; Replacement top level + +(define (replacement/make replacement decl-block) + (with-values + (lambda () + (parse-replacement (car replacement) + (cdr replacement) + decl-block)) + (lambda (table default) + (lambda (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) + (shadowed? (car candidate) decl-block block))) + (if-not-expanded) + (if-expanded + (combination/make (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) + (let ((output (make-vector len false))) + (let loop ((cases cases)) + (if (null? cases) + (values output default) + (let* ((a-case (car cases)) + (index (car a-case))) + (if (vector-ref output index) + (error "REPLACE-OPERATOR: Duplicate arity" name ocases)) + (vector-set! output index (cdr a-case)) + (loop (cdr cases))))))) + + (define (fail a-case) + (error "REPLACE-OPERATOR: Bad replacement" name a-case)) + + (define (expr->case expr) + (cons (and (symbol? expr) expr) + (->expression 'REPLACE-OPERATOR + expr + block))) + + (let parse ((cases ocases) + (parsed '()) + (len 0) + (default false)) + (if (null? cases) + (collect len parsed default) + (let ((a-case (car cases))) + (cond ((or (not (pair? a-case)) + (not (pair? (cdr a-case))) + (not (null? (cddr a-case)))) + (fail a-case)) + ((exact-nonnegative-integer? (car a-case)) + (let ((len* (car a-case)) + (expr (cadr a-case))) + (parse (cdr cases) + (cons (cons len* (expr->case expr)) + parsed) + (max (1+ len*) len) + default))) + ((memq (car a-case) '(ANY ELSE OTHERWISE)) + (if default + (error "REPLACE-OPERATOR: Duplicate default" ocases)) + (parse (cdr cases) + parsed + len + (expr->case (cadr a-case)))) + (else + (fail a-case))))))) + ;;; Local Variables: ;;; eval: (put 'decode-options 'scheme-indent-hook 2) ;;; eval: (put 'with-arguments-from 'scheme-indent-hook 1) diff --git a/v7/src/sf/sf.pkg b/v7/src/sf/sf.pkg index 126d6cf9c..a8e43be5b 100644 --- a/v7/src/sf/sf.pkg +++ b/v7/src/sf/sf.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/sf.pkg,v 4.6 1990/03/26 20:45:32 jinx Rel $ +$Id: sf.pkg,v 4.7 1992/11/04 10:17:36 jinx Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1987-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -95,7 +95,9 @@ MIT in each case. |# (export (scode-optimizer) integrate/top-level integrate/get-top-level-block - variable/final-value)) + variable/final-value) + (import (runtime parser) + lambda-optional-tag)) (define-package (scode-optimizer cgen) (files "cgen") @@ -110,6 +112,7 @@ MIT in each case. |# (parent (scode-optimizer)) (export (scode-optimizer) reducer/make + replacement/make usual-integrations/expansion-names usual-integrations/expansion-values usual-integrations/expansion-alist) diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm index 95818d1ea..a6a577c9c 100644 --- a/v7/src/sf/subst.scm +++ b/v7/src/sf/subst.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 4.6 1990/06/07 19:53:16 cph Rel $ +$Id: subst.scm,v 4.7 1992/11/04 10:17:37 jinx Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Beta Substitution +;;; package: (scode-optimizer integrate) (declare (usual-integrations) (eta-substitution) @@ -103,48 +104,75 @@ MIT in each case. |# (define define-method/integrate (expression/make-method-definer dispatch-vector)) -;;;; Lookup +;;;; Variables + +(define-method/integrate 'ASSIGNMENT + (lambda (operations environment assignment) + (let ((variable (assignment/variable assignment))) + (operations/lookup operations variable + (lambda (operation info) + info ;ignore + (case operation + ((INTEGRATE INTEGRATE-OPERATOR EXPAND) + (warn "Attempt to assign integrated name" + (variable/name variable))) + (else (error "Unknown operation" operation)))) + (lambda () 'DONE)) + ;; The value of an assignment is the old value + ;; of the variable, hence, it is refernced. + (variable/reference! variable) + (assignment/make (assignment/block assignment) + variable + (integrate/expression operations + environment + (assignment/value assignment)))))) (define *eager-integration-switch #f) (define-method/integrate 'REFERENCE (lambda (operations environment expression) (let ((variable (reference/variable expression))) - (operations/lookup operations variable - (lambda (operation info) - (case operation - ((INTEGRATE-OPERATOR EXPAND) - (variable/reference! variable) - expression) - ((INTEGRATE) - (integrate/name expression info environment - (lambda (new-expression) - (variable/integrated! variable) - new-expression) - (lambda () - (variable/reference! variable) - expression))) - (else (error "Unknown operation" operation)))) - (lambda () - (if *eager-integration-switch - (integrate/name-if-safe expression environment - (lambda (new-expression) - (variable/integrated! variable) - new-expression) - (lambda () - (variable/reference! variable) - expression)) - (begin (variable/reference! variable) - expression))))))) - -(define (integrate/name-if-safe reference environment if-win if-fail) + (letrec ((integration-success + (lambda (new-expression) + (variable/integrated! variable) + new-expression)) + (integration-failure + (lambda () + (variable/reference! variable) + expression)) + (try-safe-integration + (lambda () + (integrate/name-if-safe expression environment operations + integration-success + integration-failure)))) + (operations/lookup operations variable + (lambda (operation info) + (case operation + ((INTEGRATE-OPERATOR EXPAND) + (variable/reference! variable) + expression) + ((INTEGRATE) + (integrate/name expression info environment + integration-success + integration-failure)) + ((INTEGRATE-SAFELY) + (try-safe-integration)) + (else + (error "Unknown operation" operation)))) + (lambda () + (if *eager-integration-switch + (try-safe-integration) + (integration-failure)))))))) + +(define (integrate/name-if-safe reference environment operations + if-win if-fail) (let ((variable (reference/variable reference))) (if (or (variable/side-effected variable) (not (block/safe? (variable/block variable)))) (if-fail) (let ((finish (lambda (value) - (if (constant-value? value) + (if (constant-value? value environment operations) (if-win (copy/expression/intern (reference/block reference) value @@ -160,74 +188,73 @@ MIT in each case. |# (lambda () (if-fail)) (lambda () (if-fail))))))) -(define (constant-value? value) - (or (constant? value) - (and (reference? value) - (not (variable/side-effected (reference/variable value))) - (block/safe? (variable/block (reference/variable value)))))) +(define (constant-value? value environment operations) + (let check ((value value) (top? true)) + (or (constant? value) + (and (reference? value) + (or (not top?) + (let ((var (reference/variable value))) + (and (not (variable/side-effected var)) + (block/safe? (variable/block var)) + (environment/lookup environment var + (lambda (value*) + (check value* false)) + (lambda () + ;; unknown value + (operations/lookup operations var + (lambda (operation info) + operation info + false) + (lambda () + ;; No operations + true))) + (lambda () + ;; not found variable + true))))))))) (define (integrate/reference-operator operations environment operator operands) (let ((variable (reference/variable operator))) - (let ((dont-integrate - (lambda () - (variable/reference! variable) - (combination/optimizing-make operator operands))) - (mark-integrated! - (lambda () - (variable/integrated! variable)))) - (operations/lookup operations variable - (lambda (operation info) - (case operation - ((#F) (dont-integrate)) - ((INTEGRATE INTEGRATE-OPERATOR) - (integrate/name operator info environment - (lambda (operator) - (mark-integrated!) - (integrate/combination operations environment - operator - operands)) - dont-integrate)) - ((EXPAND) - (info operands - (lambda (new-expression) - (mark-integrated!) - (integrate/expression operations environment - new-expression)) - dont-integrate - (reference/block operator))) - (else (error "Unknown operation" operation)))) - (lambda () - (if *eager-integration-switch - (integrate/name-if-safe operator environment - (lambda (operator) - (mark-integrated!) - (integrate/combination operations - environment - operator - operands)) - dont-integrate) - (dont-integrate))))))) - -(define-method/integrate 'ASSIGNMENT - (lambda (operations environment assignment) - (let ((variable (assignment/variable assignment))) + (letrec ((mark-integrated! + (lambda () + (variable/integrated! variable))) + (integration-failure + (lambda () + (variable/reference! variable) + (combination/optimizing-make operator operands))) + (integration-success + (lambda (operator) + (mark-integrated!) + (integrate/combination operations environment + operator operands))) + (try-safe-integration + (lambda () + (integrate/name-if-safe operator environment operations + integration-success + integration-failure)))) (operations/lookup operations variable - (lambda (operation info) - info ;ignore - (case operation - ((INTEGRATE INTEGRATE-OPERATOR EXPAND) - (warn "Attempt to assign integrated name" - (variable/name variable))) - (else (error "Unknown operation" operation)))) - (lambda () 'DONE)) - ;; The value of an assignment is the old value - ;; of the variable, hence, it is refernced. - (variable/reference! variable) - (assignment/make (assignment/block assignment) - variable - (integrate/expression operations - environment - (assignment/value assignment)))))) + (lambda (operation info) + (case operation + ((#F) (integration-failure)) + ((INTEGRATE INTEGRATE-OPERATOR) + (integrate/name operator info environment + integration-success + integration-failure)) + ((INTEGRATE-SAFELY) + (try-safe-integration)) + ((EXPAND) + (info operands + (lambda (new-expression) + (mark-integrated!) + (integrate/expression operations environment + new-expression)) + integration-failure + (reference/block operator))) + (else + (error "Unknown operation" operation)))) + (lambda () + (if *eager-integration-switch + (try-safe-integration) + (integration-failure))))))) ;;;; Binding @@ -407,6 +434,12 @@ you ask for. ((and (access? operator) (system-global-environment? (access/environment operator))) (integrate/access-operator operations environment operator operands)) + ((and (constant? operator) + (eq? (constant/value operator) (ucode-primitive apply)) + (integrate/hack-apply? operands)) + => (lambda (operands*) + (integrate/combination operations environment + (car operands*) (cdr operands*)))) (else (combination/optimizing-make (if (procedure? operator) @@ -559,21 +592,7 @@ you ask for. (access/make environment* name))) (access/make (integrate/expression operations environment environment*) - name))))) - -(define (integrate/access-operator operations environment operator operands) - (let ((name (access/name operator)) - (dont-integrate - (lambda () - (combination/make operator operands)))) - (let ((entry (assq name usual-integrations/constant-alist))) - (if entry - (integrate/combination operations environment (cdr entry) operands) - (let ((entry (assq name usual-integrations/expansion-alist))) - (if entry - ((cdr entry) operands identity-procedure - dont-integrate false) - (dont-integrate))))))) + name))))) (define (system-global-environment? expression) (and (constant? expression) @@ -599,6 +618,26 @@ you ask for. (lambda (operations environment expression) operations environment ;ignore expression))) + +(define (integrate/access-operator operations environment operator operands) + (let ((name (access/name operator)) + (dont-integrate + (lambda () + (combination/make operator operands)))) + (cond ((and (eq? name 'APPLY) + (integrate/hack-apply? operands)) + => (lambda (operands*) + (integrate/combination operations environment + (car operands*) (cdr operands*)))) + ((assq name usual-integrations/constant-alist) + => (lambda (entry) + (integrate/combination operations environment (cdr entry) operands))) + ((assq name usual-integrations/expansion-alist) + => (lambda (entry) + ((cdr entry) operands identity-procedure + dont-integrate false))) + (else + (dont-integrate))))) ;;;; Environment @@ -676,7 +715,48 @@ you ask for. (bind-required environment (procedure/required procedure))) +(define (integrate/hack-apply? operands) + (define (check operand) + (cond ((constant? operand) + (if (null? (constant/value operand)) + '() + 'FAIL)) + ((not (combination? operand)) + 'FAIL) + (else + (let ((rator (combination/operator operand))) + (if (or (and (constant? rator) + (eq? (ucode-primitive cons) + (constant/value rator))) + (eq? 'cons (global-ref? rator))) + (let* ((rands (combination/operands operand)) + (next (check (cadr rands)))) + (if (eq? next 'FAIL) + 'FAIL + (cons (car rands) next))) + 'FAIL))))) + + (and (not (null? operands)) + (let ((tail (check (car (last-pair operands))))) + (and (not (eq? tail 'FAIL)) + (append (except-last-pair operands) + tail))))) + (define (simulate-application environment procedure operands) + (define (procedure->pretty procedure) + (let ((arg-list (append (procedure/required procedure) + (if (null? (procedure/optional procedure)) + '() + (cons lambda-optional-tag + (procedure/optional procedure))) + (if (not (procedure/rest procedure)) + '() + (procedure/rest procedure))))) + (if (procedure/name procedure) + `(named-lambda (,(procedure/name procedure) ,@arg-list) + ...) + `(lambda ,arg-list + ...)))) (define (match-required environment required operands) (cond ((null? required) @@ -684,7 +764,9 @@ you ask for. (procedure/optional procedure) operands)) ((null? operands) - (error "Too few operands in call to procedure" procedure)) + (error "Too few operands in call to procedure" + procedure + (procedure->pretty procedure))) (else (match-required (environment/bind environment (car required) @@ -704,16 +786,27 @@ you ask for. (cdr optional) (cdr operands))))) + (define (listify-tail operands) + (let ((const-null (constant/make '()))) + (if (null? operands) + const-null + (let ((const-cons (constant/make (ucode-primitive cons)))) + (let walk ((operands operands)) + (if (null? operands) + const-null + (combination/make const-cons + (list (car operands) + (walk (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)) + (environment/bind environment rest (listify-tail operands))) ((null? operands) environment) (else - (error "Too many operands in call to procedure" procedure)))) + (error "Too many operands in call to procedure" + procedure + (procedure->pretty procedure))))) (match-required environment (procedure/required procedure) operands)) @@ -756,16 +849,15 @@ you ask for. (set-delayed-integration/value! delayed-integration value))) ((INTEGRATED) 'DONE) ((BEING-INTEGRATED) - (error "Attempt to re-force delayed integration" delayed-integration)) + (error "Attempt to re-force delayed integration" + delayed-integration)) (else - (error "Delayed integration has unknown state" delayed-integration))) + (error "Delayed integration has unknown state" + delayed-integration))) (delayed-integration/value delayed-integration)) ;;;; Optimizations -(define combination/optimizing-make) -(let () - #| Simple LET-like combination. Delete any unreferenced parameters. If no parameters remain, delete the @@ -799,8 +891,10 @@ forms are simply removed. (foldable-constants? (cdr list))))) (define (foldable-constant-value thing) - (cond ((constant? thing) (constant/value thing)) - (else (error "can't happen")))) + (cond ((constant? thing) + (constant/value thing)) + (else + (error "foldable-constant-value: can't happen" thing)))) (define *foldable-primitive-procedures (map make-primitive-procedure @@ -818,57 +912,60 @@ forms are simply removed. ;;; Actually, we really don't want to hack with these for various ;;; reasons -(set! combination/optimizing-make - (lambda (operator operands) - (cond ( - ;; fold constants - (and (foldable-operator? operator) - (foldable-constants? operands)) - (constant/make (apply (constant/value operator) - (map foldable-constant-value operands)))) - - ( - ;; (force (delay x)) ==> x - (and (constant? operator) - (eq? (constant/value operator) force) - (= (length operands) 1) - (delay? (car operands))) - (delay/expression (car operands))) - - ((and (procedure? operator) - (null? (procedure/optional operator)) - (not (procedure/rest operator)) - (block/safe? (procedure/block operator))) - (delete-unreferenced-parameters - (procedure/required operator) - (procedure/body operator) - operands - (lambda (required referenced-operands unreferenced-operands) - (let ((form - (if (and (null? required) - ;; need to avoid things like this - ;; (foo bar (let () (define (baz) ..) ..)) - ;; optimizing into - ;; (foo bar (define (baz) ..) ..) - (not (open-block? (procedure/body operator)))) - (procedure/body operator) - (combination/make - (procedure/make - (procedure/block operator) - (procedure/name operator) - required - '() - false - (procedure/body operator)) - referenced-operands)))) - (if (null? unreferenced-operands) - form - (sequence/optimizing-make - (append unreferenced-operands (list form)))))))) - (else - (combination/make operator operands))))) +(define (combination/optimizing-make operator operands) + (cond ( + ;; fold constants + (and (foldable-operator? operator) + (foldable-constants? operands)) + (constant/make (apply (constant/value operator) + (map foldable-constant-value operands)))) + + ( + ;; (force (delay x)) ==> x + (and (constant? operator) + (eq? (constant/value operator) force) + (= (length operands) 1) + (delay? (car operands))) + (delay/expression (car operands))) + + ((and (procedure? operator) + (block/safe? (procedure/block operator)) + (for-all? (procedure/optional operator) + variable/integrated) + (or (not (procedure/rest operator)) + (variable/integrated (procedure/rest operator)))) + (delete-unreferenced-parameters + (append (procedure/required operator) + (procedure/optional operator)) + (procedure/rest operator) + (procedure/body operator) + operands + (lambda (required referenced-operands unreferenced-operands) + (let ((form + (if (and (null? required) + ;; need to avoid things like this + ;; (foo bar (let () (define (baz) ..) ..)) + ;; optimizing into + ;; (foo bar (define (baz) ..) ..) + (not (open-block? (procedure/body operator)))) + (procedure/body operator) + (combination/make + (procedure/make + (procedure/block operator) + (procedure/name operator) + required + '() + false + (procedure/body operator)) + referenced-operands)))) + (if (null? unreferenced-operands) + form + (sequence/optimizing-make + (append unreferenced-operands (list form)))))))) + (else + (combination/make operator operands)))) -(define (delete-unreferenced-parameters parameters body operands receiver) +(define (delete-unreferenced-parameters parameters rest body operands receiver) (let ((free-in-body (free/expression body))) (let loop ((parameters parameters) (operands operands) @@ -876,40 +973,36 @@ forms are simply removed. (referenced-operands '()) (unreferenced-operands '())) (cond ((null? parameters) - (if (null? operands) + (if (or rest (null? operands)) (receiver (reverse required-parameters) ; preserve order (reverse referenced-operands) - unreferenced-operands) + (append operands unreferenced-operands)) (error "Argument mismatch" operands))) ((null? operands) (error "Argument mismatch" parameters)) - (else (let ((this-parameter (car parameters)) - (this-operand (car operands))) - (cond ((set/member? free-in-body this-parameter) - (loop (cdr parameters) - (cdr operands) - (cons this-parameter required-parameters) - (cons this-operand referenced-operands) - unreferenced-operands)) - ((variable/integrated this-parameter) - (loop (cdr parameters) - (cdr operands) - required-parameters - referenced-operands - unreferenced-operands)) - (else - (loop (cdr parameters) - (cdr operands) - required-parameters - referenced-operands - (cons this-operand unreferenced-operands)))))))) - )) - - -;;; end COMBINATION/OPTIMIZING-MAKE -) + (else + (let ((this-parameter (car parameters)) + (this-operand (car operands))) + (cond ((set/member? free-in-body this-parameter) + (loop (cdr parameters) + (cdr operands) + (cons this-parameter required-parameters) + (cons this-operand referenced-operands) + unreferenced-operands)) + ((variable/integrated this-parameter) + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + unreferenced-operands)) + (else + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + (cons this-operand + unreferenced-operands)))))))))) - (define *block-optimizing-switch #f) ;; This is overly hairy, but if it works, no one need know. @@ -925,13 +1018,8 @@ forms are simply removed. ;; 5 Re-optimize the code in the body. This can help if the ;; eta-substitution-switch is on. -(define open-block/optimizing-make) - -(let () - -(set! open-block/optimizing-make - (named-lambda (open-block/optimizing-make block vars values actions - operations environment) +(define (open-block/optimizing-make block vars values actions + operations environment) (if (and *block-optimizing-switch (block/safe? block)) (let ((table:var->vals (associate-vars-and-vals vars values)) @@ -939,24 +1027,25 @@ forms are simply removed. (let ((table:vals->free (get-free-vars-in-bindings bound-variables values)) (body-free (get-body-free-vars bound-variables actions))) -; (write-string "Free vars in body") -; (display (map variable/name body-free)) + ; (write-string "Free vars in body") + ; (display (map variable/name body-free)) (let ((graph (build-graph vars table:var->vals table:vals->free body-free))) (collapse-circularities! graph) - ;(print-graph graph) + ;(print-graph graph) (label-node-depth! graph) (let ((template (linearize graph))) - ; (print-template template) + ; (print-template template) (integrate/expression operations environment (build-new-code template - (block/parent block) - table:var->vals actions)))))) - (open-block/make block vars values actions #t)))) + (block/parent block) + table:var->vals actions)))))) + (open-block/make block vars values actions #t))) +#| (define (print-template template) (if (null? template) '() @@ -965,6 +1054,7 @@ forms are simply removed. (display (car this)) (display (map variable/name (cdr this))) (print-template (cdr template))))) +|# (define (associate-vars-and-vals vars vals) (let ((table (make-generic-eq?-table))) @@ -1051,27 +1141,18 @@ forms are simply removed. (define-integrable (make-letrec-node variable-set) (%make-node 'LETREC variable-set)) -(declare (integrate add-node-need! - remove-node-need! - add-node-needed-by! - remove-node-needed-by!)) - -(define (add-node-need! needer what-i-need) - (declare (integrate what-i-need)) +(define-integrable (add-node-need! needer what-i-need) (set-%node-needs! needer (set/adjoin (%node-needs needer) what-i-need))) -(define (remove-node-need! needer what-i-no-longer-need) - (declare (integrate what-i-no-longer-need)) +(define-integrable (remove-node-need! needer what-i-no-longer-need) (set-%node-needs! needer (set/remove (%node-needs needer) what-i-no-longer-need))) -(define (add-node-needed-by! needee what-needs-me) - (declare (integrate what-needs-me)) +(define-integrable (add-node-needed-by! needee what-needs-me) (set-%node-needed-by! needee (set/adjoin (%node-needed-by needee) what-needs-me))) -(define (remove-node-needed-by! needee what-needs-me) - (declare (integrate what-needs-me)) +(define-integrable (remove-node-needed-by! needee what-needs-me) (set-%node-needed-by! needee (set/remove (%node-needed-by needee) what-needs-me))) @@ -1087,24 +1168,20 @@ forms are simply removed. (link-nodes! body-free table:var->vals table:vals->free vars table:variable->node))) -(declare (integrate link-2-nodes!)) - -(define (link-2-nodes! from-node to-node) +(define-integrable (link-2-nodes! from-node to-node) (add-node-need! from-node to-node) (add-node-needed-by! to-node from-node)) (define (unlink-node! node) (set/for-each (lambda (needer) - (remove-node-needed-by! needer node)) - (%node-needs node)) + (remove-node-needed-by! needer node)) + (%node-needs node)) (set/for-each (lambda (needee) - (remove-node-need! needee node)) - (%node-needed-by node)) + (remove-node-need! needee node)) + (%node-needed-by node)) (set-%node-type! node 'UNLINKED)) -(declare (integrate unlink-nodes!)) - -(define (unlink-nodes! nodelist) +(define-integrable (unlink-nodes! nodelist) (for-each unlink-node! nodelist)) (define (link-nodes! body-free @@ -1195,7 +1272,8 @@ forms are simply removed. nodeset))) (let ((letrec-node (make-letrec-node varset))) - (set/for-each (lambda (need) (link-2-nodes! letrec-node need)) needs-set) + (set/for-each (lambda (need) (link-2-nodes! letrec-node need)) + needs-set) (set/for-each (lambda (needer) (link-2-nodes! needer letrec-node)) needed-by) ;; now delete nodes in nodelist @@ -1212,6 +1290,7 @@ forms are simply removed. (1+ depth))))) (label-nodes! (singleton-nodeset graph) 0)) +#| (define (print-graph node) (if (null? node) '() @@ -1224,6 +1303,7 @@ forms are simply removed. (display (variable/name variable))) (%node-vars node)) (set/for-each print-graph (%node-needs node))))) +|# (define (collapse-parallel-nodelist depth nodeset) (if (set/empty? nodeset) @@ -1303,7 +1383,4 @@ forms are simply removed. (length this-vals) open-block/value-marker) (list code)) - #t))))))))))) - -;; End of OPEN-BLOCK/OPTIMIZING-MAKE -) \ No newline at end of file + #t))))))))))) \ No newline at end of file diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index 25ab659d3..8ee7c01a0 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.8 1991/11/04 20:31:46 cph Exp $ +$Id: toplev.scm,v 4.9 1992/11/04 10:17:39 jinx Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Top Level +;;; package: (scode-optimizer top-level) (declare (usual-integrations)) @@ -56,11 +57,13 @@ MIT in each case. |# (if (default-object? bin-string) false bin-string) (if (default-object? spec-string) false 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." (fluid-let ((wrapping-hook wrap-with-control-point)) (syntax-file input-string bin-string spec-string))) +|# (define (syntax&integrate s-expression declarations #!optional syntax-table) (fluid-let ((sf:noisy? false)) @@ -278,6 +281,7 @@ Currently only the 68000 implementation needs this." (define (wrapping-hook scode) scode) +#| (define control-point-tail `(3 ,(object-new-type (microcode-type 'NULL) 16) () () () () () () () () () () () () () () ())) @@ -298,6 +302,7 @@ Currently only the 68000 implementation needs this." (define return-address-non-existent-continuation (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION))) +|# ;;;; Optimizer Top Level diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index a22b45dfb..556c3c3f3 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 4.9 1991/05/06 18:46:23 jinx Exp $ +$Id: usiexp.scm,v 4.10 1992/11/04 10:17:40 jinx Exp $ -Copyright (c) 1988-1991 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -253,8 +253,8 @@ MIT in each case. |# block (if (< 1 (length operands) 10) (if-expanded - (make-combination - (ucode-primitive apply) + (combination/make + (global-ref/make 'APPLY) (list (car operands) (cons*-expansion-loop (cdr operands))))) (if-not-expanded))) diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm index f29f02700..13523cc2a 100644 --- a/v8/src/sf/make.scm +++ b/v8/src/sf/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.23 1992/02/08 15:10:16 cph Exp $ +$Id: make.scm,v 4.24 1992/11/04 10:17:31 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -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 23 '())) \ No newline at end of file +(add-system! (make-system "SF" 4 24 '())) \ No newline at end of file diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm index 014240942..8ee7c01a0 100644 --- a/v8/src/sf/toplev.scm +++ b/v8/src/sf/toplev.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.8 1991/11/04 20:31:46 cph Exp $ +$Id: toplev.scm,v 4.9 1992/11/04 10:17:39 jinx Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Top Level +;;; package: (scode-optimizer top-level) (declare (usual-integrations)) @@ -56,11 +57,13 @@ MIT in each case. |# (if (default-object? bin-string) false bin-string) (if (default-object? spec-string) false 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." (fluid-let ((wrapping-hook wrap-with-control-point)) (syntax-file input-string bin-string spec-string))) +|# (define (syntax&integrate s-expression declarations #!optional syntax-table) (fluid-let ((sf:noisy? false)) @@ -278,6 +281,7 @@ Currently only the 68000 implementation needs this." (define (wrapping-hook scode) scode) +#| (define control-point-tail `(3 ,(object-new-type (microcode-type 'NULL) 16) () () () () () () () () () () () () () () ())) @@ -298,6 +302,7 @@ Currently only the 68000 implementation needs this." (define return-address-non-existent-continuation (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION))) +|# ;;;; Optimizer Top Level -- 2.25.1