home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
mitsch75.zip
/
scheme-7_5_17-src.zip
/
scheme-7.5.17
/
src
/
sf
/
usiexp.scm
< prev
next >
Wrap
Text File
|
2000-03-16
|
23KB
|
785 lines
#| -*-Scheme-*-
$Id: usiexp.scm,v 4.40 2000/03/16 17:20:06 cph Exp $
Copyright (c) 1988-2000 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|#
;;;; SCode Optimizer: Usual Integrations: Combination Expansions
;;; package: (scode-optimizer expansion)
(declare (usual-integrations)
(integrate-external "object"))
;;;; Fixed-arity arithmetic primitives
(define (make-combination expression block primitive operands)
(combination/make (and expression (object/scode expression))
block
(constant/make #f primitive)
operands))
(define (make-operand-binding expression block operand make-body)
(combination/make (and expression (object/scode expression))
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 block
(reference/make #f block variable)))))
(list operand)))
(define (constant-eq? expression constant)
(and (constant? expression)
(eq? (constant/value expression) constant)))
(define (unary-arithmetic primitive)
(lambda (expr operands if-expanded if-not-expanded block)
(if (and (pair? operands)
(null? (cdr 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)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded (make-combination expr block primitive operands))
(if-not-expanded))))
(define zero?-expansion
(unary-arithmetic (ucode-primitive zero?)))
(define positive?-expansion
(unary-arithmetic (ucode-primitive positive?)))
(define negative?-expansion
(unary-arithmetic (ucode-primitive negative?)))
(define 1+-expansion
(unary-arithmetic (ucode-primitive 1+)))
(define -1+-expansion
(unary-arithmetic (ucode-primitive -1+)))
(define quotient-expansion
(binary-arithmetic (ucode-primitive quotient 2)))
(define remainder-expansion
(binary-arithmetic (ucode-primitive remainder 2)))
(define modulo-expansion
(binary-arithmetic (ucode-primitive modulo 2)))
;;;; N-ary Arithmetic Predicates
(define (pairwise-test binary-predicate if-left-zero if-right-zero)
(lambda (expr operands if-expanded if-not-expanded block)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(cond ((constant-eq? (car operands) 0)
(make-combination expr block if-left-zero
(list (cadr operands))))
((constant-eq? (cadr operands) 0)
(make-combination expr block if-right-zero
(list (car operands))))
(else
(make-combination expr block binary-predicate operands))))
(if-not-expanded))))
(define (pairwise-test-inverse inverse-expansion)
(lambda (expr operands if-expanded if-not-expanded block)
(inverse-expansion
expr operands
(lambda (expression)
(if-expanded
(make-combination expr block (ucode-primitive not)
(list expression))))
if-not-expanded
block)))
(define =-expansion
(pairwise-test (ucode-primitive &=)
(ucode-primitive zero?)
(ucode-primitive zero?)))
(define <-expansion
(pairwise-test (ucode-primitive &<)
(ucode-primitive positive?)
(ucode-primitive negative?)))
(define >-expansion
(pairwise-test (ucode-primitive &>)
(ucode-primitive negative?)
(ucode-primitive positive?)))
(define <=-expansion (pairwise-test-inverse >-expansion))
(define >=-expansion (pairwise-test-inverse <-expansion))
;;;; Fixnum Operations
(define (fix:zero?-expansion expr operands if-expanded if-not-expanded block)
(if (and (pair? operands) (null? (cdr operands)))
(if-expanded
(make-combination expr block (ucode-primitive eq?)
(list (car operands) (constant/make #f 0))))
(if-not-expanded)))
(define (fix:=-expansion expr operands if-expanded if-not-expanded block)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr 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)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(make-combination
expr
block
(ucode-primitive not)
(list (make-combination #f
block
(ucode-primitive greater-than-fixnum?)
operands))))
(if-not-expanded)))
(define (fix:>=-expansion expr operands if-expanded if-not-expanded block)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(make-combination
expr
block
(ucode-primitive not)
(list (make-combination #f
block
(ucode-primitive less-than-fixnum?)
operands))))
(if-not-expanded)))
;;;; N-ary Arithmetic Field Operations
(define (right-accumulation identity make-binary)
(lambda (expr operands if-expanded if-not-expanded block)
(let ((operands (delq identity operands)))
(let ((n (length operands)))
(cond ((zero? n)
(if-expanded (constant/make
(and expr (object/scode expr))
identity)))
((< n 5)
(if-expanded
(let loop
((expr expr)
(first (car operands))
(rest (cdr operands)))
(if (null? rest)
first
(make-binary expr
block
first
(loop #f (car rest) (cdr rest)))))))
(else
(if-not-expanded)))))))
(define +-expansion
(right-accumulation 0
(lambda (expr block x y)
(cond ((constant-eq? x 1)
(make-combination expr block (ucode-primitive 1+) (list y)))
((constant-eq? y 1)
(make-combination expr block (ucode-primitive 1+) (list x)))
(else
(make-combination expr block (ucode-primitive &+) (list x y)))))))
(define *-expansion
(right-accumulation 1
(lambda (expr block x y)
(make-combination expr block (ucode-primitive &*) (list x y)))))
(define (expt-expansion expr operands if-expanded if-not-expanded block)
(let ((make-binder
(lambda (make-body)
(make-operand-binding expr
block
(car operands)
make-body))))
(cond ((not (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands))))
(if-not-expanded))
;;((constant-eq? (cadr operands) 0)
;; (if-expanded (constant/make (and expr (object/scode expr)) 1)))
((constant-eq? (cadr operands) 1)
(if-expanded (car operands)))
((constant-eq? (cadr operands) 2)
(make-binder
(lambda (block operand)
(make-combination #f
block
(ucode-primitive &*)
(list operand operand)))))
((constant-eq? (cadr operands) 3)
(make-binder
(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 (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-not-expanded)))))
(define (right-accumulation-inverse identity inverse-expansion make-binary)
(lambda (expr operands if-expanded if-not-expanded block)
(let ((expand
(lambda (expr x y)
(if-expanded
(if (constant-eq? y identity)
x
(make-binary expr block x y))))))
(cond ((null? operands)
(if-not-expanded))
((null? (cdr operands))
(expand expr (constant/make #f identity) (car operands)))
(else
(inverse-expansion #f (cdr operands)
(lambda (expression)
(expand expr (car operands) expression))
if-not-expanded
block))))))
(define --expansion
(right-accumulation-inverse 0 +-expansion
(lambda (expr block x y)
(if (constant-eq? y 1)
(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 block x y)
(make-combination expr block (ucode-primitive &/) (list x y)))))
;;;; N-ary List Operations
(define (apply*-expansion expr operands if-expanded if-not-expanded block)
(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 #f block (cdr operands)))))
(if-not-expanded)))
(define (cons*-expansion expr operands if-expanded if-not-expanded block)
(if (< -1 (length operands) 9)
(if-expanded (cons*-expansion-loop expr block operands))
(if-not-expanded)))
(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 #f block (cdr rest))))))
(define (list-expansion expr operands if-expanded if-not-expanded block)
(if (< (length operands) 9)
(if-expanded (list-expansion-loop expr block operands))
(if-not-expanded)))
(define (list-expansion-loop expr block rest)
(if (null? rest)
(constant/make (and expr (object/scode expr)) '())
(make-combination expr block (ucode-primitive cons)
(list (car rest)
(list-expansion-loop #f block (cdr rest))))))
(define (values-expansion expr operands if-expanded if-not-expanded block)
if-not-expanded
(if-expanded
(let ((block (block/make block #t '())))
(let ((variables
(map (lambda (operand)
operand
(variable/make&bind! block
(string->uninterned-symbol "value")))
operands)))
(combination/make
(and expr (object/scode expr))
block
(procedure/make
#f
block lambda-tag:let variables '() #f
(let ((block (block/make block #t '())))
(let ((variable (variable/make&bind! block 'RECEIVER)))
(procedure/make
#f block lambda-tag:unnamed (list variable) '() #f
(combination/make #f
block
(reference/make #f block variable)
(map (lambda (variable)
(reference/make #f block variable))
variables))))))
operands)))))
(define (call-with-values-expansion expr operands
if-expanded if-not-expanded block)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(combination/make (and expr (object/scode expr))
block
(combination/make #f block (car operands) '())
(cdr operands)))
(if-not-expanded)))
;;;; General CAR/CDR Encodings
(define (general-car-cdr-expansion encoding)
(lambda (expr operands if-expanded if-not-expanded block)
(if (= (length operands) 1)
(if-expanded
(make-combination expr
block
(ucode-primitive general-car-cdr)
(list (car operands)
(constant/make #f encoding))))
(if-not-expanded))))
(define caar-expansion (general-car-cdr-expansion #b111))
(define cadr-expansion (general-car-cdr-expansion #b110))
(define cdar-expansion (general-car-cdr-expansion #b101))
(define cddr-expansion (general-car-cdr-expansion #b100))
(define caaar-expansion (general-car-cdr-expansion #b1111))
(define caadr-expansion (general-car-cdr-expansion #b1110))
(define cadar-expansion (general-car-cdr-expansion #b1101))
(define caddr-expansion (general-car-cdr-expansion #b1100))
(define cdaar-expansion (general-car-cdr-expansion #b1011))
(define cdadr-expansion (general-car-cdr-expansion #b1010))
(define cddar-expansion (general-car-cdr-expansion #b1001))
(define cdddr-expansion (general-car-cdr-expansion #b1000))
(define caaaar-expansion (general-car-cdr-expansion #b11111))
(define caaadr-expansion (general-car-cdr-expansion #b11110))
(define caadar-expansion (general-car-cdr-expansion #b11101))
(define caaddr-expansion (general-car-cdr-expansion #b11100))
(define cadaar-expansion (general-car-cdr-expansion #b11011))
(define cadadr-expansion (general-car-cdr-expansion #b11010))
(define caddar-expansion (general-car-cdr-expansion #b11001))
(define cadddr-expansion (general-car-cdr-expansion #b11000))
(define cdaaar-expansion (general-car-cdr-expansion #b10111))
(define cdaadr-expansion (general-car-cdr-expansion #b10110))
(define cdadar-expansion (general-car-cdr-expansion #b10101))
(define cdaddr-expansion (general-car-cdr-expansion #b10100))
(define cddaar-expansion (general-car-cdr-expansion #b10011))
(define cddadr-expansion (general-car-cdr-expansion #b10010))
(define cdddar-expansion (general-car-cdr-expansion #b10001))
(define cddddr-expansion (general-car-cdr-expansion #b10000))
(define first-expansion (general-car-cdr-expansion #b11))
(define second-expansion cadr-expansion)
(define third-expansion caddr-expansion)
(define fourth-expansion cadddr-expansion)
(define fifth-expansion (general-car-cdr-expansion #b110000))
(define sixth-expansion (general-car-cdr-expansion #b1100000))
(define seventh-expansion (general-car-cdr-expansion #b11000000))
(define eighth-expansion (general-car-cdr-expansion #b110000000))
;;;; Miscellaneous
(define (make-string-expansion expr operands if-expanded if-not-expanded block)
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(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)
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded (make-type-test expr block type (car operands)))
(if-not-expanded))))
(define weak-pair?-expansion (type-test-expansion (ucode-type weak-cons)))
(define (exact-integer?-expansion expr operands if-expanded if-not-expanded
block)
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-operand-binding expr block (car operands)
(lambda (block operand)
(make-disjunction
expr
(make-type-test #f block (ucode-type fixnum) operand)
(make-type-test #f block (ucode-type big-fixnum) operand)))))
(if-not-expanded)))
(define (exact-rational?-expansion expr operands if-expanded if-not-expanded
block)
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-operand-binding expr block (car operands)
(lambda (block operand)
(make-disjunction
expr
(make-type-test #f block (ucode-type fixnum) operand)
(make-type-test #f block (ucode-type big-fixnum) operand)
(make-type-test #f block (ucode-type ratnum) operand)))))
(if-not-expanded)))
(define (complex?-expansion expr operands if-expanded if-not-expanded block)
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-operand-binding expr block (car operands)
(lambda (block operand)
(make-disjunction
expr
(make-type-test #f block (ucode-type fixnum) operand)
(make-type-test #f block (ucode-type big-fixnum) operand)
(make-type-test #f block (ucode-type ratnum) operand)
(make-type-test #f block (ucode-type big-flonum) operand)
(make-type-test #f block (ucode-type recnum) operand)))))
(if-not-expanded)))
(define (symbol?-expansion expr operands if-expanded if-not-expanded block)
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-operand-binding expr block (car operands)
(lambda (block operand)
(make-disjunction
expr
(make-type-test #f block (ucode-type interned-symbol) operand)
(make-type-test #f block (ucode-type uninterned-symbol)
operand)))))
(if-not-expanded)))
(define (make-disjunction expr . clauses)
(let loop ((clauses clauses))
(if (null? (cdr clauses))
(car clauses)
(disjunction/make (and expr (object/scode expr))
(car clauses) (loop (cdr clauses))))))
(define (make-type-test expr block type operand)
(make-combination expr block
(ucode-primitive object-type?)
(list (constant/make #f type) operand)))
(define (string->symbol-expansion expr operands if-expanded if-not-expanded
block)
block
(if (and (pair? operands)
(constant? (car operands))
(string? (constant/value (car operands)))
(null? (cdr operands)))
(if-expanded
(constant/make (and expr (object/scode expr))
(string->symbol (constant/value (car operands)))))
(if-not-expanded)))
(define (intern-expansion expr operands if-expanded if-not-expanded block)
block
(if (and (pair? operands)
(constant? (car operands))
(string? (constant/value (car operands)))
(null? (cdr operands)))
(if-expanded
(constant/make (and expr (object/scode expr))
(intern (constant/value (car operands)))))
(if-not-expanded)))
(define (int:->flonum-expansion expr operands if-expanded if-not-expanded
block)
(if (and (pair? operands)
(null? (cdr operands)))
(if-expanded
(make-combination expr
block
(ucode-primitive integer->flonum 2)
(list (car operands) (constant/make #f #b10))))
(if-not-expanded)))
(define (flo:<=-expansion expr operands if-expanded if-not-expanded block)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(make-combination
expr
block
(ucode-primitive not)
(list (make-combination #f
block
(ucode-primitive flonum-greater?)
operands))))
(if-not-expanded)))
(define (flo:>=-expansion expr operands if-expanded if-not-expanded block)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
(if-expanded
(make-combination
expr
block
(ucode-primitive not)
(list (make-combination #f
block
(ucode-primitive flonum-less?)
operands))))
(if-not-expanded)))
;;;; Tables
(define usual-integrations/expansion-names
'(
*
+
-
-1+
/
1+
<
<=
=
>
>=
apply
caaaar
caaadr
caaar
caadar
caaddr
caadr
caar
cadaar
cadadr
cadar
caddar
cadddr
caddr
cadr
call-with-values
cdaaar
cdaadr
cdaar
cdadar
cdaddr
cdadr
cdar
cddaar
cddadr
cddar
cdddar
cddddr
cdddr
cddr
char=?
complex?
cons*
eighth
exact-integer?
exact-rational?
expt
fifth
first
fix:<=
fix:=
fix:>=
flo:<=
flo:>=
fourth
int:->flonum
int:integer?
intern
list
make-string
;; modulo ; Compiler does not currently open-code it.
negative?
number?
positive?
quotient
remainder
second
seventh
sixth
string->symbol
symbol?
third
values
weak-pair?
with-values
zero?
))
(define usual-integrations/expansion-values
(list
*-expansion
+-expansion
--expansion
-1+-expansion
/-expansion
1+-expansion
<-expansion
<=-expansion
=-expansion
>-expansion
>=-expansion
apply*-expansion
caaaar-expansion
caaadr-expansion
caaar-expansion
caadar-expansion
caaddr-expansion
caadr-expansion
caar-expansion
cadaar-expansion
cadadr-expansion
cadar-expansion
caddar-expansion
cadddr-expansion
caddr-expansion
cadr-expansion
call-with-values-expansion
cdaaar-expansion
cdaadr-expansion
cdaar-expansion
cdadar-expansion
cdaddr-expansion
cdadr-expansion
cdar-expansion
cddaar-expansion
cddadr-expansion
cddar-expansion
cdddar-expansion
cddddr-expansion
cdddr-expansion
cddr-expansion
char=?-expansion
complex?-expansion
cons*-expansion
eighth-expansion
exact-integer?-expansion
exact-rational?-expansion
expt-expansion
fifth-expansion
first-expansion
fix:<=-expansion
fix:=-expansion
fix:>=-expansion
flo:<=-expansion
flo:>=-expansion
fourth-expansion
int:->flonum-expansion
exact-integer?-expansion
intern-expansion
list-expansion
make-string-expansion
;; modulo-expansion
negative?-expansion
complex?-expansion
positive?-expansion
quotient-expansion
remainder-expansion
second-expansion
seventh-expansion
sixth-expansion
string->symbol-expansion
symbol?-expansion
third-expansion
values-expansion
weak-pair?-expansion
call-with-values-expansion
zero?-expansion
))
(define usual-integrations/expansion-alist
(map cons
usual-integrations/expansion-names
usual-integrations/expansion-values))
;;;; Hooks and utilities for user defined reductions and expanders
;;; User defined reductions appear in reduct.scm
;;; Scode->Scode expanders
(define (scode->scode-expander scode-expander)
(lambda (expr operands if-expanded if-not-expanded block)
(scode-expander
(map cgen/external-with-declarations operands)
(lambda (scode-expression)
(if-expanded
(reassign
expr
(transform/recursive
block
(integrate/get-top-level-block)
scode-expression))))
if-not-expanded)))
;;; Kludge for EXPAND-OPERATOR declaration.
(define expander-evaluation-environment
(the-environment))
