diff options
author | Mark H Weaver <mhw@netris.org> | 2013-08-13 09:03:23 -0400 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-08-24 15:18:32 +0200 |
commit | 62d3430cb618e8d45b0e72d195fdee6e2550ea91 (patch) | |
tree | c48951a5bef280cde24ea02c3d1c763d0ea39f63 | |
parent | 453acfacf408fafe0712f8796e06241d236d011a (diff) | |
download | guile-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.scm | 28 |
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 |