summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2013-08-13 09:03:23 -0400
committerAndy Wingo <wingo@pobox.com>2013-08-24 15:18:32 +0200
commit62d3430cb618e8d45b0e72d195fdee6e2550ea91 (patch)
treec48951a5bef280cde24ea02c3d1c763d0ea39f63
parent453acfacf408fafe0712f8796e06241d236d011a (diff)
downloadguile-62d3430cb618e8d45b0e72d195fdee6e2550ea91.tar.gz
Convert branchable primitives into binary operations only.
* module/language/tree-il/primitives.scm (maybe-simplify-to-eq): Wrap within another lambda, binding the primitive name. If there are less than two arguments, expand to constant #t. If there are more than two arguments, convert into a conjunction of binary applications. (expand-chained-comparisons): New procedure. (*primitive-expand-table*): Add entries for (< <= = >= > eq?).
-rw-r--r--module/language/tree-il/primitives.scm28
1 files changed, 25 insertions, 3 deletions
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 06b7a110f..0fe444567 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -509,8 +509,10 @@
(bytevector-ieee-double-native-set! vec (* i 8) x))
;; Appropriate for use with either 'eqv?' or 'equal?'.
-(define maybe-simplify-to-eq
+(define (maybe-simplify-to-eq prim)
(case-lambda
+ ((src) (make-const src #t))
+ ((src a) (make-const src #t))
((src a b)
;; Simplify cases where either A or B is constant.
(define (maybe-simplify a b)
@@ -524,10 +526,30 @@
(>= v most-negative-fixnum)))
(make-primcall src 'eq? (list a b))))))
(or (maybe-simplify a b) (maybe-simplify b a)))
+ ((src a b . rest)
+ (make-conditional src (make-primcall src prim (list a b))
+ (make-primcall src prim (cons b rest))
+ (make-const src #f)))
(else #f)))
-(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq)
-(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'eqv? (maybe-simplify-to-eq 'eqv?))
+(hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?))
+
+(define (expand-chained-comparisons prim)
+ (case-lambda
+ ((src) (make-const src #t))
+ ((src a) (make-const src #t))
+ ((src a b) #f)
+ ((src a b . rest)
+ (make-conditional src (make-primcall src prim (list a b))
+ (make-primcall src prim (cons b rest))
+ (make-const src #f)))
+ (else #f)))
+
+(for-each (lambda (prim)
+ (hashq-set! *primitive-expand-table* prim
+ (expand-chained-comparisons prim)))
+ '(< <= = >= > eq?))
(hashq-set! *primitive-expand-table*
'call-with-prompt