mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

Convert branchable primitives into binary operations only.

Browse source 
* 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?).
This commit is contained in:
Mark H Weaver 2013-08-13 09:03:23 -04:00 • committed by Andy Wingo
parent 453acfacf4
commit 62d3430cb6
1 changed files with 25 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

28
module/language/tree-il/primitives.scm
View file

@ -509,8 +509,10 @@
(bytevector-ieee-double-native-set! vec (* i 8) x)) (bytevector-ieee-double-native-set! vec (* i 8) x))
;; Appropriate for use with either 'eqv?' or 'equal?'. ;; Appropriate for use with either 'eqv?' or 'equal?'.
(define maybe-simplify-to-eq (define (maybe-simplify-to-eq prim)
(case-lambda (case-lambda
((src) (make-const src #t))
((src a) (make-const src #t))
((src a b) ((src a b)
;; Simplify cases where either A or B is constant. ;; Simplify cases where either A or B is constant.
(define (maybe-simplify a b) (define (maybe-simplify a b)
@ -524,10 +526,30 @@
(>= v most-negative-fixnum))) (>= v most-negative-fixnum)))
(make-primcall src 'eq? (list a b)))))) (make-primcall src 'eq? (list a b))))))
(or (maybe-simplify a b) (maybe-simplify b a))) (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))) (else #f)))
(hashq-set! *primitive-expand-table* 'eqv? 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) (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* (hashq-set! *primitive-expand-table*
'call-with-prompt 'call-with-prompt