#| -*-Scheme-*-
-$Id: copy.scm,v 4.3 1993/08/03 03:09:45 gjr Exp $
+$Id: copy.scm,v 4.4 1993/09/01 00:10:20 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(lambda (block environment expression)
(combination/make
(combination/scode expression)
+ block
(copy/expression block environment (combination/operator expression))
(copy/expressions block environment (combination/operands expression)))))
#| -*-Scheme-*-
-$Id: make.scm,v 4.26 1993/01/02 07:33:35 cph Exp $
+$Id: make.scm,v 4.27 1993/09/01 00:10:47 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(package/system-loader "sf" '() 'QUERY)
((package/reference (find-package '(SCODE-OPTIMIZER))
'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 26 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 27 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: object.scm,v 4.6 1993/08/03 03:09:47 gjr Exp $
+$Id: object.scm,v 4.7 1993/09/01 00:10:22 cph Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
(define-simple-type variable (block name flags) #F)
(define-simple-type access (environment name))
(define-simple-type assignment (block variable value))
- (define-simple-type combination (operator operands))
+ (define-simple-type combination (block operator operands))
(define-simple-type conditional (predicate consequent alternative))
(define-simple-type constant (value))
(define-simple-type declaration (declarations expression))
#| -*-Scheme-*-
-$Id: pardec.scm,v 4.8 1993/08/03 22:40:23 jacob Exp $
+$Id: pardec.scm,v 4.9 1993/09/01 00:10:24 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(change-type/expression value)
(list
(make-declaration operation
- (block/lookup-name block name true)
+ (if (symbol? name)
+ (block/lookup-name block name true)
+ name)
(make-integration-info
(copy/expression/extern block value))
true))))))
(finish (integration-info/expression value)))
((dumpable-expander? value)
(vector operation
- (variable/name variable)
+ (if (variable? variable)
+ (variable/name variable)
+ variable)
(dumpable-expander->dumped-expander value)))
(else
(error "Unrecognized extern value:" value))))))))))
false))
reduction-rules)))
-(define-declaration 'REPLACE-OPERATOR
- (lambda (block replacements)
- (check-declaration-syntax 'REPLACE-OPERATOR replacements)
- (map (lambda (replacement)
- (make-declaration 'EXPAND
- (block/lookup-name block (car replacement) true)
- (make-dumpable-expander
- (replacement/make replacement block)
- `(REPLACE-OPERATOR ,replacement))
- false))
- replacements)))
-
(define (check-declaration-syntax kind declarations)
(if (not (and (list? declarations)
(for-all? declarations
(list? (cdr declaration)))))))
(error "Bad declaration:" kind declarations)))
+(define-declaration 'REPLACE-OPERATOR
+ (lambda (block replacements)
+ (if (not (and (list? replacements)
+ (for-all? replacements
+ (lambda (replacement)
+ (and (pair? replacement)
+ (or (symbol? (car replacement))
+ (and (pair? (car replacement))
+ (eq? 'PRIMITIVE (caar replacement))
+ (pair? (cdar replacement))
+ (symbol? (cadar replacement))
+ (or (null? (cddar replacement))
+ (and (pair? (cddar replacement))
+ (null? (cdddar replacement))))))
+ (list? (cdr replacement)))))))
+ (error "Bad declaration:" 'REPLACE-OPERATOR replacements))
+ (map (lambda (replacement)
+ (make-declaration
+ 'EXPAND
+ (let ((name (car replacement)))
+ (cond ((symbol? name)
+ (block/lookup-name block name true))
+ ((and (pair? name)
+ (eq? (car name) 'PRIMITIVE))
+ (make-primitive-procedure (cadr name)
+ (and (not (null? (cddr name)))
+ (caddr name))))
+ (else
+ (error "Illegal name in replacement:" name))))
+ (make-dumpable-expander
+ (replacement/make replacement block)
+ `(REPLACE-OPERATOR ,replacement))
+ false))
+ replacements)))
+\f
(define (make-dumpable-expander expander declaration)
(make-entity (lambda (self expr operands if-expanded if-not-expanded block)
self ; ignored
#| -*-Scheme-*-
-$Id: reduct.scm,v 4.7 1993/08/03 22:40:00 jacob Exp $
+$Id: reduct.scm,v 4.8 1993/09/01 00:10:25 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(else
(loop (cdr l) done)))))
-(define (combine-1 unop x)
- (combination/make false unop (list x)))
+(define (combine-1 block unop x)
+ (combination/make false block unop (list x)))
-(define (combine-2 binop x y)
- (combination/make false binop (list x y)))
+(define (combine-2 block binop x y)
+ (combination/make false block binop (list x y)))
\f
;;;; Building blocks
(declare (integrate mapper))
(lambda (block value combiner)
combiner ; ignored
- (combine-1 (mapper block) value)))))
+ (combine-1 block (mapper block) value)))))
(define (->wrapper mapper)
(handle-variable mapper
(declare (integrate mapper))
(lambda (block not-reduced reduced)
(combination/make false
+ block
(mapper block)
(append not-reduced
(list reduced)))))))
(lambda (expr)
(declare (integrate expr))
(lambda (block x y)
- (combine-2 (expr block) x y)))))))
+ (combine-2 block (expr block) x y)))))))
(lambda (expr operands if-expanded if-not-expanded block)
(define (group l)
(define (replacement/make replacement decl-block)
(call-with-values
- (lambda ()
- (parse-replacement (car replacement)
- (cdr replacement)
- decl-block))
- (lambda (table default)
- (lambda (expr operands if-expanded if-not-expanded block)
- (let* ((len (length operands))
- (candidate (or (and (< len (vector-length table))
- (vector-ref table len))
- default)))
- (if (or (not (pair? candidate))
- (and (car candidate)
- (block/limited-lookup block
- (car candidate)
- decl-block)))
- (if-not-expanded)
- (if-expanded
- (combination/make
- (and expr (object/scode expr))
- (let ((frob (cdr candidate)))
- (if (variable? frob)
- (lookup (variable/name frob) block)
- frob))
- operands))))))))
+ (lambda ()
+ (parse-replacement (car replacement)
+ (cdr replacement)
+ decl-block))
+ (lambda (table default)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (let* ((len (length operands))
+ (candidate (or (and (< len (vector-length table))
+ (vector-ref table len))
+ default)))
+ (if (or (not (pair? candidate))
+ (and (car candidate)
+ (block/limited-lookup block
+ (car candidate)
+ decl-block)))
+ (if-not-expanded)
+ (if-expanded
+ (combination/make (and expr (object/scode expr))
+ block
+ (let ((frob (cdr candidate)))
+ (if (variable? frob)
+ (lookup (variable/name frob) block)
+ frob))
+ operands))))))))
(define (parse-replacement name ocases block)
(define (collect len cases default)
#| -*-Scheme-*-
-$Id: subst.scm,v 4.10 1993/08/03 03:09:49 gjr Exp $
+$Id: subst.scm,v 4.11 1993/09/01 00:10:26 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
;; not found variable
true)))))))))
\f
-(define (integrate/reference-operator expression operations
- environment operator operands)
+(define (integrate/reference-operator expression operations environment
+ block operator operands)
(let ((variable (reference/variable operator)))
(letrec ((mark-integrated!
(lambda ()
(integration-failure
(lambda ()
(variable/reference! variable)
- (combination/optimizing-make expression operator operands)))
+ (combination/optimizing-make expression block
+ operator operands)))
(integration-success
(lambda (operator)
(mark-integrated!)
- (integrate/combination expression
- operations environment
- operator operands)))
+ (integrate/combination expression operations environment
+ block operator operands)))
(try-safe-integration
(lambda ()
(integrate/name-if-safe expression operator
(lambda (operations environment combination)
(integrate/combination
combination operations environment
+ (combination/block combination)
(combination/operator combination)
(integrate/expressions operations
environment
(combination/operands combination)))))
(define (integrate/combination expression operations environment
- operator operands)
+ block operator operands)
(cond ((reference? operator)
(integrate/reference-operator expression operations environment
- operator operands))
+ block operator operands))
((and (access? operator)
(system-global-environment? (access/environment operator)))
(integrate/access-operator expression operations environment
- operator operands))
+ block operator operands))
((and (constant? operator)
- (eq? (constant/value operator) (ucode-primitive apply))
- (integrate/hack-apply? operands))
- => (lambda (operands*)
- (integrate/combination expression
- operations environment
- (car operands*) (cdr operands*))))
+ (primitive-procedure? (constant/value operator)))
+ (let ((operands*
+ (and (eq? (constant/value operator) (ucode-primitive apply))
+ (integrate/hack-apply? operands))))
+ (if operands*
+ (integrate/combination expression operations environment
+ block (car operands*) (cdr operands*))
+ (integrate/primitive-operator expression operations environment
+ block operator operands))))
(else
(combination/optimizing-make
expression
+ block
(if (procedure? operator)
(integrate/procedure-operator operations environment
- operator operands)
+ block operator operands)
(let ((operator
(integrate/expression operations environment operator)))
(if (procedure? operator)
(integrate/procedure-operator operations environment
- operator operands)
+ block operator operands)
operator)))
operands))))
(define (integrate/procedure-operator operations environment
- procedure operands)
+ block procedure operands)
(integrate/procedure operations
- (simulate-application environment procedure operands)
+ (simulate-application environment block
+ procedure operands)
procedure))
+(define (integrate/primitive-operator expression operations environment
+ block operator operands)
+ (let ((integration-failure
+ (lambda ()
+ (combination/optimizing-make expression block operator operands))))
+ (operations/lookup operations (constant/value operator)
+ (lambda (operation info)
+ (case operation
+ ((#F) (integration-failure))
+ ((EXPAND)
+ (info expression
+ operands
+ (lambda (expression)
+ (integrate/expression operations environment expression))
+ integration-failure
+ block))
+ (else (error "Unknown operation" operation))))
+ integration-failure)))
+\f
(define-method/integrate 'DECLARATION
(lambda (operations environment declaration)
(let ((declarations (declaration/declarations declaration))
(integrate/expression (declarations/bind operations declarations)
environment
expression)))))
-\f
+
;;;; Easy Cases
(define-method/integrate 'CONSTANT
operations environment ;ignore
expression)))
-(define (integrate/access-operator expression operations
- environment operator operands)
+(define (integrate/access-operator expression operations environment
+ block operator operands)
(let ((name (access/name operator))
(dont-integrate
(lambda ()
(combination/make (and expression (object/scode expression))
- operator operands))))
+ block operator operands))))
(cond ((and (eq? name 'APPLY)
(integrate/hack-apply? operands))
=> (lambda (operands*)
- (integrate/combination expression
- operations environment
- (car operands*) (cdr operands*))))
+ (integrate/combination expression operations environment
+ block (car operands*) (cdr operands*))))
((assq name usual-integrations/constant-alist)
=> (lambda (entry)
- (integrate/combination expression
- operations environment
- (cdr entry) operands)))
+ (integrate/combination expression operations environment
+ block (cdr entry) operands)))
((assq name usual-integrations/expansion-alist)
=> (lambda (entry)
((cdr entry) expression operands
(append (except-last-pair operands)
tail)))))
\f
-(define (simulate-application environment procedure operands)
+(define (simulate-application environment block procedure operands)
(define (procedure->pretty procedure)
(if (procedure/scode procedure)
(unsyntax (procedure/scode procedure))
(let walk ((operands operands))
(if (null? operands)
const-null
- (combination/make false const-cons
+ (combination/make false
+ block
+ const-cons
(list (car operands)
(walk (cdr operands))))))))))
;;; Actually, we really don't want to hack with these for various
;;; reasons
-(define (combination/optimizing-make expression operator operands)
+(define (combination/optimizing-make expression block operator operands)
(cond (
;; fold constants
(and (foldable-operator? operator)
(reassign expression (procedure/body operator))
(combination/make
(and expression (object/scode expression))
+ block
(procedure/make
(procedure/scode operator)
(procedure/block operator)
(append unreferenced-operands (list form))))))))
(else
(combination/make (and expression (object/scode expression))
- operator operands))))
+ block operator operands))))
\f
(define (delete-unreferenced-parameters parameters rest body operands receiver)
(let ((free-in-body (free/expression body)))
block
(combination/optimizing-make
(and expression (object/scode expression))
+ block
(procedure/make
false
block
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.11 1993/08/03 02:26:28 gjr Exp $
+$Id: toplev.scm,v 4.12 1993/09/01 00:10:28 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(string->symbol "#[(scode-optimizer top-level)externs-file]"))
(define externs-file-version
- 3)
+ 4)
\f
;;;; Optimizer Top Level
#| -*-Scheme-*-
-$Id: usiexp.scm,v 4.17 1993/08/31 20:53:51 cph Exp $
+$Id: usiexp.scm,v 4.18 1993/09/01 00:10:29 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
\f
;;;; Fixed-arity arithmetic primitives
-(define (make-combination expression primitive operands)
+(define (make-combination expression block primitive operands)
(combination/make (and expression
(object/scode expression))
+ block
(constant/make false primitive)
operands))
(define (unary-arithmetic primitive)
(lambda (expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(null? (cdr operands)))
- (if-expanded (make-combination expr primitive operands))
+ (if-expanded (make-combination expr block primitive operands))
(if-not-expanded))))
(define (binary-arithmetic primitive)
(lambda (expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
- (if-expanded (make-combination expr primitive operands))
+ (if-expanded (make-combination expr block primitive operands))
(if-not-expanded))))
(define zero?-expansion
(define (pairwise-test binary-predicate if-left-zero if-right-zero)
(lambda (expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(cond ((constant-eq? (car operands) 0)
- (make-combination expr if-left-zero (list (cadr operands))))
+ (make-combination expr block if-left-zero
+ (list (cadr operands))))
((constant-eq? (cadr operands) 0)
- (make-combination expr if-right-zero (list (car operands))))
+ (make-combination expr block if-right-zero
+ (list (car operands))))
(else
- (make-combination expr binary-predicate operands))))
+ (make-combination expr block binary-predicate operands))))
(if-not-expanded))))
(define (pairwise-test-inverse inverse-expansion)
expr operands
(lambda (expression)
(if-expanded
- (make-combination expr (ucode-primitive not) (list expression))))
+ (make-combination expr block (ucode-primitive not)
+ (list expression))))
if-not-expanded
block)))
;;;; Fixnum Operations
(define (fix:zero?-expansion expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands) (null? (cdr operands)))
(if-expanded
- (make-combination expr (ucode-primitive eq?)
+ (make-combination expr block (ucode-primitive eq?)
(list (car operands) (constant/make false 0))))
(if-not-expanded)))
(define (fix:=-expansion expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
- (if-expanded (make-combination expr (ucode-primitive eq?) operands))
+ (if-expanded
+ (make-combination expr block (ucode-primitive eq?) operands))
(if-not-expanded)))
(define char=?-expansion
fix:=-expansion)
(define (fix:<=-expansion expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(make-combination
expr
+ block
(ucode-primitive not)
(list (make-combination false
+ block
(ucode-primitive greater-than-fixnum?)
operands))))
(if-not-expanded)))
(define (fix:>=-expansion expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(make-combination
expr
+ block
(ucode-primitive not)
(list (make-combination false
+ block
(ucode-primitive less-than-fixnum?)
operands))))
(if-not-expanded)))
(define (right-accumulation identity make-binary)
(lambda (expr operands if-expanded if-not-expanded block)
- block ; ignored
(let ((operands (delq identity operands)))
(let ((n (length operands)))
(cond ((zero? n)
(if (null? rest)
first
(make-binary expr
+ block
first
(loop false (car rest) (cdr rest)))))))
(else
(define +-expansion
(right-accumulation 0
- (lambda (expr x y)
+ (lambda (expr block x y)
(cond ((constant-eq? x 1)
- (make-combination expr (ucode-primitive 1+) (list y)))
+ (make-combination expr block (ucode-primitive 1+) (list y)))
((constant-eq? y 1)
- (make-combination expr (ucode-primitive 1+) (list x)))
+ (make-combination expr block (ucode-primitive 1+) (list x)))
(else
- (make-combination expr (ucode-primitive &+) (list x y)))))))
+ (make-combination expr block (ucode-primitive &+) (list x y)))))))
(define *-expansion
(right-accumulation 1
- (lambda (expr x y)
- (make-combination expr (ucode-primitive &*) (list x y)))))
+ (lambda (expr block x y)
+ (make-combination expr block (ucode-primitive &*) (list x y)))))
\f
(define (expt-expansion expr operands if-expanded if-not-expanded block)
(let ((make-binder
(if-expanded
(combination/make
(and expr (object/scode expr))
+ block
(let ((block (block/make block #t '()))
(name (string->uninterned-symbol "operand")))
(let ((variable (variable/make&bind! block name)))
(procedure/make
#f
block lambda-tag:let (list variable) '() #f
- (make-body (reference/make false block variable)))))
+ (make-body block (reference/make false block variable)))))
(list (car operands)))))))
(cond ((not (and (pair? operands)
(pair? (cdr operands))
(if-expanded (car operands)))
((constant-eq? (cadr operands) 2)
(make-binder
- (lambda (operand)
+ (lambda (block operand)
(make-combination #f
+ block
(ucode-primitive &*)
(list operand operand)))))
((constant-eq? (cadr operands) 3)
(make-binder
- (lambda (operand)
+ (lambda (block operand)
(make-combination
#f
+ block
(ucode-primitive &*)
(list operand
(make-combination #f
+ block
(ucode-primitive &*)
(list operand operand)))))))
((constant-eq? (cadr operands) 4)
(make-binder
- (lambda (operand)
+ (lambda (block operand)
(make-combination
#f
+ block
(ucode-primitive &*)
(list (make-combination #f
+ block
(ucode-primitive &*)
(list operand operand))
(make-combination #f
+ block
(ucode-primitive &*)
(list operand operand)))))))
(else
(if-expanded
(if (constant-eq? y identity)
x
- (make-binary expr x y))))))
+ (make-binary expr block x y))))))
(cond ((null? operands)
(if-not-expanded))
((null? (cdr operands))
(define --expansion
(right-accumulation-inverse 0 +-expansion
- (lambda (expr x y)
+ (lambda (expr block x y)
(if (constant-eq? y 1)
- (make-combination expr (ucode-primitive -1+) (list x))
- (make-combination expr (ucode-primitive &-) (list x y))))))
+ (make-combination expr block (ucode-primitive -1+) (list x))
+ (make-combination expr block (ucode-primitive &-) (list x y))))))
(define /-expansion
(right-accumulation-inverse 1 *-expansion
- (lambda (expr x y)
- (make-combination expr (ucode-primitive &/) (list x y)))))
+ (lambda (expr block x y)
+ (make-combination expr block (ucode-primitive &/) (list x y)))))
\f
;;;; N-ary List Operations
(define (apply*-expansion expr operands if-expanded if-not-expanded block)
- block
(if (< 1 (length operands) 10)
(if-expanded
(combination/make
(and expr (object/scode expr))
+ block
(global-ref/make 'APPLY)
- (list (car operands) (cons*-expansion-loop false (cdr operands)))))
+ (list (car operands)
+ (cons*-expansion-loop false block (cdr operands)))))
(if-not-expanded)))
(define (cons*-expansion expr operands if-expanded if-not-expanded block)
- block
(if (< -1 (length operands) 9)
- (if-expanded (cons*-expansion-loop expr operands))
+ (if-expanded (cons*-expansion-loop expr block operands))
(if-not-expanded)))
-(define (cons*-expansion-loop expr rest)
+(define (cons*-expansion-loop expr block rest)
(if (null? (cdr rest))
(car rest)
(make-combination expr
+ block
(ucode-primitive cons)
(list (car rest)
- (cons*-expansion-loop false (cdr rest))))))
+ (cons*-expansion-loop false block (cdr rest))))))
(define (list-expansion expr operands if-expanded if-not-expanded block)
- block ; ignored
(if (< (length operands) 9)
- (if-expanded (list-expansion-loop expr operands))
+ (if-expanded (list-expansion-loop expr block operands))
(if-not-expanded)))
-(define (list-expansion-loop expr rest)
+(define (list-expansion-loop expr block rest)
(if (null? rest)
(constant/make (and expr (object/scode expr)) '())
- (make-combination expr (ucode-primitive cons)
+ (make-combination expr block (ucode-primitive cons)
(list (car rest)
- (list-expansion-loop false (cdr rest))))))
+ (list-expansion-loop false block (cdr rest))))))
(define (values-expansion expr operands if-expanded if-not-expanded block)
if-not-expanded
operands)))
(combination/make
(and expr (object/scode expr))
+ block
(procedure/make
false
block lambda-tag:let variables '() false
(procedure/make
false block lambda-tag:unnamed (list variable) '() false
(combination/make false
+ block
(reference/make false block variable)
(map (lambda (variable)
(reference/make false block variable))
(define (call-with-values-expansion expr operands
if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(combination/make (and expr (object/scode expr))
- (combination/make false (car operands) '())
+ block
+ (combination/make false block (car operands) '())
(cdr operands)))
(if-not-expanded)))
\f
(define (general-car-cdr-expansion encoding)
(lambda (expr operands if-expanded if-not-expanded block)
- block
(if (= (length operands) 1)
(if-expanded
(make-combination expr
+ block
(ucode-primitive general-car-cdr)
(list (car operands)
(constant/make false encoding))))
;;;; Miscellaneous
(define (make-string-expansion expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
- (make-combination expr (ucode-primitive string-allocate) operands))
+ (make-combination expr block (ucode-primitive string-allocate)
+ operands))
(if-not-expanded)))
(define (type-test-expansion type)
(lambda (expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(null? (cdr operands)))
- (if-expanded (make-type-test expr type (car operands)))
+ (if-expanded (make-type-test expr block type (car operands)))
(if-not-expanded))))
(define char?-expansion (type-test-expansion (ucode-type character)))
(define (exact-integer?-expansion expr operands if-expanded if-not-expanded
block)
- block
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-disjunction
expr
- (make-type-test false (ucode-type fixnum) (car operands))
- (make-type-test false (ucode-type big-fixnum) (car operands))))
+ (make-type-test false block (ucode-type fixnum) (car operands))
+ (make-type-test false block (ucode-type big-fixnum) (car operands))))
(if-not-expanded)))
(define (exact-rational?-expansion expr operands if-expanded if-not-expanded
block)
- block
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-disjunction
expr
- (make-type-test false (ucode-type fixnum) (car operands))
- (make-type-test false (ucode-type big-fixnum) (car operands))
- (make-type-test false (ucode-type ratnum) (car operands))))
+ (make-type-test false block (ucode-type fixnum) (car operands))
+ (make-type-test false block (ucode-type big-fixnum) (car operands))
+ (make-type-test false block (ucode-type ratnum) (car operands))))
(if-not-expanded)))
(define (complex?-expansion expr operands if-expanded if-not-expanded block)
- block
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-disjunction
expr
- (make-type-test false (ucode-type fixnum) (car operands))
- (make-type-test false (ucode-type big-fixnum) (car operands))
- (make-type-test false (ucode-type ratnum) (car operands))
- (make-type-test false (ucode-type big-flonum) (car operands))
- (make-type-test false (ucode-type recnum) (car operands))))
+ (make-type-test false block (ucode-type fixnum) (car operands))
+ (make-type-test false block (ucode-type big-fixnum) (car operands))
+ (make-type-test false block (ucode-type ratnum) (car operands))
+ (make-type-test false block (ucode-type big-flonum) (car operands))
+ (make-type-test false block (ucode-type recnum) (car operands))))
(if-not-expanded)))
\f
(define (make-disjunction expr . clauses)
(disjunction/make (and expr (object/scode expr))
(car clauses) (loop (cdr clauses))))))
-(define (make-type-test expr type operand)
- (make-combination expr
+(define (make-type-test expr block type operand)
+ (make-combination expr block
(ucode-primitive object-type?)
(list (constant/make false type) operand)))
#| -*-Scheme-*-
-$Id: xform.scm,v 4.5 1993/08/03 03:09:54 gjr Exp $
+$Id: xform.scm,v 4.6 1993/09/01 00:10:31 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(combination-components expression*
(lambda (operator operands)
(combination/make expression
+ block
(transform/expression block environment operator)
(transform/expressions block environment operands)))))
#| -*-Scheme-*-
-$Id: make.scm,v 4.26 1993/01/02 07:33:35 cph Exp $
+$Id: make.scm,v 4.27 1993/09/01 00:10:47 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(package/system-loader "sf" '() 'QUERY)
((package/reference (find-package '(SCODE-OPTIMIZER))
'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 26 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 27 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.11 1993/08/03 02:26:28 gjr Exp $
+$Id: toplev.scm,v 4.12 1993/09/01 00:10:28 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(string->symbol "#[(scode-optimizer top-level)externs-file]"))
(define externs-file-version
- 3)
+ 4)
\f
;;;; Optimizer Top Level
projects / mit-scheme.git / commitdiff