From d97034ab79a6676551ad0023ebe73b64ec26743f Mon Sep 17 00:00:00 2001
From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Wed, 10 Feb 2010 18:14:22 -0800
Subject: [PATCH] Convert usiexp.scm from CPS to direct style. Fix callers in
subst.scm.
---
src/sf/subst.scm | 75 +++++---
src/sf/usiexp.scm | 469 +++++++++++++++++++++++-----------------------
2 files changed, 276 insertions(+), 268 deletions(-)
diff --git a/src/sf/subst.scm b/src/sf/subst.scm
index 68ad5bbb6..a18bfbab0 100644
--- a/src/sf/subst.scm
+++ b/src/sf/subst.scm
@@ -159,14 +159,13 @@ USA.
integration-success
integration-failure))
((EXPAND)
- (info expression
- operands
- (lambda (new-expression)
+ (let ((new-expression (info expression operands (reference/block operator))))
+ (if new-expression
+ (begin
(mark-integrated!)
- (integrate/expression operations environment
- new-expression))
- integration-failure
- (reference/block operator)))
+ (integrate/expression operations environment new-expression))
+ (integration-failure))))
+
(else
(error "Unknown operation" operation))))
(lambda ()
@@ -613,31 +612,45 @@ USA.
operations environment ;ignore
expression)))
-(define (integrate/access-operator expression operations environment
- block operator operands)
+(define (integrate/access-operator expression operations environment block operator operands)
(let ((name (access/name operator))
- (dont-integrate
- (lambda ()
- (combination/make
- expression
- block
- (integrate/expression operations environment operator)
- (integrate/expressions operations environment operands)))))
- (cond ((and (eq? name 'APPLY)
- (integrate/hack-apply? operands))
- => (lambda (operands*)
- (integrate/combination expression operations environment
- block (car operands*) (cdr operands*))))
- ((assq name usual-integrations/constant-alist)
- => (lambda (entry)
- (integrate/combination expression operations environment
- block (cdr entry) operands)))
- ((assq name usual-integrations/expansion-alist)
- => (lambda (entry)
- ((cdr entry) expression operands
- identity-procedure dont-integrate #f)))
- (else
- (dont-integrate)))))
+ (environment*
+ (integrate/expression operations environment (access/environment operator))))
+
+ (define (dont-integrate)
+ (combination/make
+ expression block
+ (access/make (access/scode operator) environment* name) operands))
+
+ (if (not (constant/system-global-environment? environment*))
+ (dont-integrate)
+ (operations/lookup-global
+ operations name
+ (lambda (operation info)
+ (case operation
+ ((#F) (dont-integrate));; shadowed
+
+ ((INTEGRATE INTEGRATE-OPERATOR)
+ ;; This branch is never taken because all the global
+ ;; operators are defined via expansions. But if that
+ ;; ever changes...
+ (integrate/name expression
+ operator info environment
+ (lambda (new-operator)
+ (integrate/combination
+ expression operations environment
+ block new-operator operands))
+ dont-integrate))
+
+ ((EXPAND)
+ (cond ((info expression operands (reference/block operator))
+ => (lambda (new-expression)
+ (integrate/expression operations environment new-expression)))
+ (else (dont-integrate))))
+
+ (else
+ (error "unknown operation" operation))))
+ dont-integrate))))
;;;; Environment
diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm
index 60c298997..585f98e35 100644
--- a/src/sf/usiexp.scm
+++ b/src/sf/usiexp.scm
@@ -55,19 +55,19 @@ USA.
(eq? (constant/value expression) constant)))
(define (unary-arithmetic primitive)
- (lambda (expr operands if-expanded if-not-expanded block)
+ (lambda (expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (if-expanded (make-combination expr block primitive operands))
- (if-not-expanded))))
+ (make-combination expr block primitive operands)
+ #f)))
(define (binary-arithmetic primitive)
- (lambda (expr operands if-expanded if-not-expanded block)
+ (lambda (expr operands block)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
- (if-expanded (make-combination expr block primitive operands))
- (if-not-expanded))))
+ (make-combination expr block primitive operands)
+ #f)))
(define zero?-expansion
(unary-arithmetic (ucode-primitive zero?)))
@@ -96,31 +96,27 @@ USA.
;;;; N-ary Arithmetic Predicates
(define (pairwise-test binary-predicate if-left-zero if-right-zero)
- (lambda (expr operands if-expanded if-not-expanded block)
+ (lambda (expr operands 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))))
+ (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)))
+ #f)))
(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)))
+ (lambda (expr operands block)
+ (let ((inverse (inverse-expansion expr operands block)))
+ (if inverse
+ (make-combination expr block (ucode-primitive not)
+ (list inverse))
+ #f))))
(define =-expansion
(pairwise-test (ucode-primitive &=)
@@ -142,78 +138,72 @@ USA.
;;;; Fixnum Operations
-(define (fix:zero?-expansion expr operands if-expanded if-not-expanded block)
+(define (fix:zero?-expansion expr operands 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)))
+ (make-combination expr block (ucode-primitive eq?)
+ (list (car operands) (constant/make #f 0)))
+ #f))
-(define (fix:=-expansion expr operands if-expanded if-not-expanded block)
+(define (fix:=-expansion expr operands block)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
- (if-expanded
- (make-combination expr block (ucode-primitive eq?) operands))
- (if-not-expanded)))
+ (make-combination expr block (ucode-primitive eq?) operands)
+ #f))
(define char=?-expansion
fix:=-expansion)
-(define (fix:<=-expansion expr operands if-expanded if-not-expanded block)
+(define (fix:<=-expansion expr operands 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)
+ (make-combination
+ expr
+ block
+ (ucode-primitive not)
+ (list (make-combination #f
+ block
+ (ucode-primitive greater-than-fixnum?)
+ operands)))
+ #f))
+
+(define (fix:>=-expansion expr operands 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)))
+ (make-combination
+ expr
+ block
+ (ucode-primitive not)
+ (list (make-combination #f
+ block
+ (ucode-primitive less-than-fixnum?)
+ operands)))
+ #f))
;;;; N-ary Arithmetic Field Operations
(define (right-accumulation identity make-binary)
- (lambda (expr operands if-expanded if-not-expanded block)
+ (lambda (expr operands block)
(let ((operands (delq identity operands)))
(let ((n (length operands)))
(cond ((zero? n)
- (if-expanded (constant/make
- (and expr (object/scode expr))
- identity)))
+ (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)))))))
+ (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 #f))))))
(define +-expansion
(right-accumulation 0
@@ -230,7 +220,7 @@ USA.
(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)
+(define (expt-expansion expr operands block)
(let ((make-binder
(lambda (make-body)
(make-operand-binding expr
@@ -240,11 +230,11 @@ USA.
(cond ((not (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands))))
- (if-not-expanded))
+ #f)
;;((constant-eq? (cadr operands) 0)
;; (if-expanded (constant/make (and expr (object/scode expr)) 1)))
((constant-eq? (cadr operands) 1)
- (if-expanded (car operands)))
+ (car operands))
((constant-eq? (cadr operands) 2)
(make-binder
(lambda (block operand)
@@ -279,27 +269,23 @@ USA.
block
(ucode-primitive &*)
(list operand operand)))))))
- (else
- (if-not-expanded)))))
+ (else #f))))
(define (right-accumulation-inverse identity inverse-expansion make-binary)
- (lambda (expr operands if-expanded if-not-expanded block)
+ (lambda (expr operands 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))
+ (make-binary expr block x y)))))
+ (cond ((null? operands) #f)
((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))))))
+ (let ((inverse (inverse-expansion #f (cdr operands) block)))
+ (if inverse
+ (expand expr (car operands) inverse)
+ #f)))))))
(define --expansion
(right-accumulation-inverse 0 +-expansion
@@ -315,21 +301,47 @@ USA.
;;;; N-ary List Operations
-(define (apply*-expansion expr operands if-expanded if-not-expanded block)
- (if (< 1 (length operands) 10)
- (if-expanded
- (combination/make
- 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)
+(define sf:enable-flatten-apply? #t)
+
+(define (apply*-expansion expr operands block)
+ (cond ((< (length operands) 2) #f)
+ ((= 2 (length operands))
+ (if (and (manifest-argument-list? (second operands))
+ (noisy-test sf:enable-flatten-apply? "flatten-apply"))
+ (combination/make expr block (first operands) (flatten-operands (second operands)))
+ (make-combination expr block (ucode-primitive apply) operands)))
+ ((< (length operands) 10)
+ (apply*-expansion
+ expr
+ (list (car operands)
+ (cons*-expansion-loop #f block (cdr operands)))
+ block))
+ (else #f)))
+
+;;; If an argument constructs a null-terminated list, we flatten
+;;; the call to apply.
+(define (manifest-argument-list? expr)
+ (or (constant-eq? expr '())
+ (and (combination? expr)
+ (let ((operator (combination/operator expr))
+ (operands (combination/operands expr)))
+ (and (or (constant-eq? operator (ucode-primitive cons))
+ (eq? (global-ref? operator) 'cons))
+ (pair? operands)
+ (pair? (cdr operands))
+ (null? (cddr operands))
+ (manifest-argument-list? (second operands)))))))
+
+(define (flatten-operands operands)
+ (unfold (lambda (operands) (constant-eq? operands '()))
+ (lambda (operands) (first (combination/operands operands)))
+ (lambda (operands) (second (combination/operands operands)))
+ operands))
+
+(define (cons*-expansion expr operands block)
(if (< -1 (length operands) 9)
- (if-expanded (cons*-expansion-loop expr block operands))
- (if-not-expanded)))
+ (cons*-expansion-loop expr block operands)
+ #f))
(define (cons*-expansion-loop expr block rest)
(if (null? (cdr rest))
@@ -340,10 +352,10 @@ USA.
(list (car rest)
(cons*-expansion-loop #f block (cdr rest))))))
-(define (list-expansion expr operands if-expanded if-not-expanded block)
+(define (list-expansion expr operands block)
(if (< (length operands) 9)
- (if-expanded (list-expansion-loop expr block operands))
- (if-not-expanded)))
+ (list-expansion-loop expr block operands)
+ #f))
(define (list-expansion-loop expr block rest)
(if (null? rest)
@@ -352,65 +364,61 @@ USA.
(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 (position)
- (variable/make&bind!
- block
- (string->uninterned-symbol
- (string-append "value-" (number->string position)))))
- (iota (length operands)))))
- (combination/make
- 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
- (declaration/make
- #f
- ;; The receiver is used only once, and all its operand
- ;; expressions are effect-free, so integrating here is
- ;; safe.
- (declarations/parse block '((INTEGRATE-OPERATOR RECEIVER)))
- (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)
+(define (values-expansion expr operands block)
+ (let ((block (block/make block #t '())))
+ (let ((variables
+ (map (lambda (position)
+ (variable/make&bind!
+ block
+ (string->uninterned-symbol
+ (string-append "value-" (number->string position)))))
+ (iota (length operands)))))
+ (combination/make
+ 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
+ (declaration/make
+ #f
+ ;; The receiver is used only once, and all its operand
+ ;; expressions are effect-free, so integrating here is
+ ;; safe.
+ (declarations/parse block '((INTEGRATE-OPERATOR RECEIVER)))
+ (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 block)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
- (if-expanded
- (combination/make expr
- block
- (combination/make #f block (car operands) '())
- (cdr operands)))
- (if-not-expanded)))
+ (combination/make expr
+ block
+ (combination/make #f block (car operands) '())
+ (cdr operands))
+ #f))
+
;;;; General CAR/CDR Encodings
(define (general-car-cdr-expansion encoding)
- (lambda (expr operands if-expanded if-not-expanded block)
+ (lambda (expr operands 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))))
+ (make-combination expr
+ block
+ (ucode-primitive general-car-cdr)
+ (list (car operands)
+ (constant/make #f encoding)))
+ #f)))
(define caar-expansion (general-car-cdr-expansion #b111))
(define cadr-expansion (general-car-cdr-expansion #b110))
@@ -454,54 +462,49 @@ USA.
;;;; Miscellaneous
-(define (make-string-expansion expr operands if-expanded if-not-expanded block)
+(define (make-string-expansion expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (if-expanded
- (make-combination expr block (ucode-primitive string-allocate)
- operands))
- (if-not-expanded)))
+ (make-combination expr block (ucode-primitive string-allocate)
+ operands)
+ #f))
(define (type-test-expansion type)
- (lambda (expr operands if-expanded if-not-expanded block)
+ (lambda (expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (if-expanded (make-type-test expr block type (car operands)))
- (if-not-expanded))))
+ (make-type-test expr block type (car operands))
+ #f)))
(define weak-pair?-expansion (type-test-expansion (ucode-type weak-cons)))
-(define (exact-integer?-expansion expr operands if-expanded if-not-expanded
- block)
+(define (exact-integer?-expansion expr operands 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)
+ (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))))
+ #f))
+
+(define (exact-rational?-expansion expr operands 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)))
+ (make-type-test #f block (ucode-type ratnum) operand))))
+ #f))
-(define (complex?-expansion expr operands if-expanded if-not-expanded block)
+(define (complex?-expansion expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (if-expanded
(make-operand-binding expr block (car operands)
(lambda (block operand)
(make-disjunction
@@ -510,31 +513,29 @@ USA.
(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)))
+ (make-type-test #f block (ucode-type recnum) operand))))
+ #f))
-(define (symbol?-expansion expr operands if-expanded if-not-expanded block)
+(define (symbol?-expansion expr operands 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 (default-object?-expansion expr operands if-expanded if-not-expanded
- block)
+ (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))))
+ #f))
+
+(define (default-object?-expansion expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (if-expanded
- (make-combination expr block (ucode-primitive eq?)
- (list (car operands)
- (constant/make #f (default-object)))))
- (if-not-expanded)))
+ (make-combination expr block (ucode-primitive eq?)
+ (list (car operands)
+ (constant/make #f (default-object))))
+ #f))
(define (make-disjunction expr . clauses)
(let loop ((clauses clauses))
@@ -548,45 +549,40 @@ USA.
(ucode-primitive object-type?)
(list (constant/make #f type) operand)))
-(define (string->symbol-expansion expr operands if-expanded if-not-expanded
- block)
- block
+(define (string->symbol-expansion expr operands block)
+ (declare (ignore 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)))
+ (constant/make (and expr (object/scode expr))
+ (string->symbol (constant/value (car operands))))
+ #f))
-(define (intern-expansion expr operands if-expanded if-not-expanded block)
- block
+(define (intern-expansion expr operands block)
+ (declare (ignore 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)))
+ (constant/make (and expr (object/scode expr))
+ (intern (constant/value (car operands))))
+ #f))
-(define (int:->flonum-expansion expr operands if-expanded if-not-expanded
- block)
+(define (int:->flonum-expansion expr operands 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)))
+ (make-combination expr
+ block
+ (ucode-primitive integer->flonum 2)
+ (list (car operands) (constant/make #f #b10)))
+ #f))
(define (make-primitive-expander primitive)
- (lambda (expr operands if-expanded if-not-expanded block)
+ (lambda (expr operands block)
(if (procedure-arity-valid? primitive (length operands))
- (if-expanded (make-combination expr block primitive operands))
- (if-not-expanded))))
+ (make-combination expr block primitive operands)
+ #f)))
;;;; Tables
@@ -766,18 +762,17 @@ USA.
;;; Scode->Scode expanders
(define (scode->scode-expander scode-expander)
- (lambda (expr operands if-expanded if-not-expanded block)
+ (lambda (expr operands 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)))
+ (reassign
+ expr
+ (transform/recursive
+ block
+ (integrate/get-top-level-block)
+ scode-expression)))
+ false-procedure)))
;;; Kludge for EXPAND-OPERATOR declaration.
(define expander-evaluation-environment
--
2.25.1