#| -*-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
(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
#| -*-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
MIT in each case. |#
;;;; SCode Optimizer: Data Types
+;;; package: (scode-optimizer)
(declare (usual-integrations)
(automagic-integrations)
;;; 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))
#| -*-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
MIT in each case. |#
;;;; SCode Optimizer: Parse Declarations
+;;; package: (scode-optimizer declarations)
(declare (usual-integrations)
(open-block-optimizations)
(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
(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)
(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)))))))
\f
-;;;; 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.
#| -*-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
MIT in each case. |#
;;;; SCode Optimizer: User defined reductions
+;;; package: (scode-optimizer expansion)
(declare (usual-integrations)
(automagic-integrations)
(eta-substitution)
(integrate-external "object"))
\f
-;;;; 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 (<name> (<nargs1> <value1>) (<nargs2> <value2>) ...))
+
+<name> is a symbol
+<nargs1> is a non-negative integer or one of the symbols ANY, ELSE, and OTHERWISE.
+<valueN> is a simple expression:
+ <symbol> ; means a variable
+ (QUOTE <constant>) = '<constant> ; means a constant
+ (PRIMITIVE <primitive name> { <arity> }) ; means a primitive
+ (GLOBAL <variable>) ; means a global variable
+
+replaces non-shadowed calls to <name> with <nargsN> arguments
+with a call to <valueN> 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))
+|#
+\f
+#|
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 (<name> <binop>
{ (group <ordering>)
(null-value <value> <null-option>)
(singleton <unop>)
- (wrapper <wrap>)
+ (wrapper <wrap> {<n>})
+ (maximum <m>)
}))
<name> is a symbol
-<binop>, <value>, <unop>, and <wrap> are simple expressions
-(currently not checked):
- '<constant>
- <variable>
- (primitive <primitive name> { <arity> })
+<n> and <m> are non-negative integers.
+
+<binop>, <value>, <unop>, and <wrap> are simple expressions as above.
<null-option> is a member of {ALWAYS, ANY, ONE, SINGLE, NONE, EMPTY}
6) The wrapper option specifies a function, <wrap>, to be invoked on the
result of the outermost call to <binop> after the expansion.
+If <n> 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 <m> 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))))
|#
\f
(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)
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))))
\f
;; any-shadowed? prevents reductions in any environment where any of
;; the names introduced by the reduction has been shadowed. The
(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
(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)
\f
;;;; 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
(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))
\f
;;;; 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
'()
(cons
(let ((place (assq (car keys) options)))
- (if (null? place)
+ (if (not place)
'()
(cdr place)))
(collect (cdr keys)))))
;;;; 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))))
(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))))
\f
-;;;; 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)
(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)))))))))))
(else
(fail 'GROUP group))))))))))
\f
+;;;; 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)))))))
+\f
;;; Local Variables:
;;; eval: (put 'decode-options 'scheme-indent-hook 2)
;;; eval: (put 'with-arguments-from 'scheme-indent-hook 1)
#| -*-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
(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")
(parent (scode-optimizer))
(export (scode-optimizer)
reducer/make
+ replacement/make
usual-integrations/expansion-names
usual-integrations/expansion-values
usual-integrations/expansion-alist)
#| -*-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
MIT in each case. |#
;;;; SCode Optimizer: Beta Substitution
+;;; package: (scode-optimizer integrate)
(declare (usual-integrations)
(eta-substitution)
(define define-method/integrate
(expression/make-method-definer dispatch-vector))
\f
-;;;; 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))))))))
+\f
+(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
(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)))))))))
\f
(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)))))))
\f
;;;; Binding
((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)
(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)
(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)))))
\f
;;;; Environment
(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)))))
+\f
(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)
(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)
(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))
\f
(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))
\f
;;;; Optimizations
-(define combination/optimizing-make)
-(let ()
-
#|
Simple LET-like combination. Delete any unreferenced
parameters. If no parameters remain, delete the
(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
;;; 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))))
\f
-(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)
(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))))))))))
\f
-
(define *block-optimizing-switch #f)
;; This is overly hairy, but if it works, no one need know.
;; 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))
(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)
'()
(display (car this))
(display (map variable/name (cdr this)))
(print-template (cdr template)))))
+|#
(define (associate-vars-and-vals vars vals)
(let ((table (make-generic-eq?-table)))
(define-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)))
\f
(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
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
(1+ depth)))))
(label-nodes! (singleton-nodeset graph) 0))
+#|
(define (print-graph node)
(if (null? node)
'()
(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)
(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
#| -*-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
MIT in each case. |#
;;;; SCode Optimizer: Top Level
+;;; package: (scode-optimizer top-level)
(declare (usual-integrations))
\f
(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))
(define (wrapping-hook scode)
scode)
+#|
(define control-point-tail
`(3 ,(object-new-type (microcode-type 'NULL) 16)
() () () () () () () () () () () () () () ()))
(define return-address-non-existent-continuation
(make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION)))
+|#
\f
;;;; Optimizer Top Level
#| -*-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
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)))
#| -*-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
(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
#| -*-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
MIT in each case. |#
;;;; SCode Optimizer: Top Level
+;;; package: (scode-optimizer top-level)
(declare (usual-integrations))
\f
(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))
(define (wrapping-hook scode)
scode)
+#|
(define control-point-tail
`(3 ,(object-new-type (microcode-type 'NULL) 16)
() () () () () () () () () () () () () () ()))
(define return-address-non-existent-continuation
(make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION)))
+|#
\f
;;;; Optimizer Top Level
projects / mit-scheme.git / commitdiff