summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-10-30 10:14:48 +0100
committerAndy Wingo <wingo@pobox.com>2017-10-30 11:50:45 +0100
commit0d42f5467f9b0d7841af3043bca7ad53a6c6ee64 (patch)
tree5d027cc93708fd9f5637eca71c4d3cd51e47987b
parentd1c69b5c9546b04fc5040f3deb2ee0fce0868083 (diff)
downloadguile-0d42f5467f9b0d7841af3043bca7ad53a6c6ee64.tar.gz
Lower logtest branches to instead be 'zero? logand'
* module/language/cps/compile-bytecode.scm (compile-function): Rename the binary* helper back to binary, update uses, and remove logtest branch as we no longer put logtest in test context. * module/language/cps/primitives.scm (*comparisons*): Remove logtest. * module/language/cps/type-fold.scm: Remove logtest folder. (logbit?): Fold to logand. * module/language/cps/types.scm (logtest): Update to be a type inferrer and not a predicate inferrer. * module/language/tree-il/peval.scm (peval): Transform logtest and logbit? to (zero? (logand _ _)).
-rw-r--r--module/language/cps/compile-bytecode.scm51
-rw-r--r--module/language/cps/primitives.scm3
-rw-r--r--module/language/cps/type-fold.scm27
-rw-r--r--module/language/cps/types.scm5
-rw-r--r--module/language/tree-il/peval.scm26
5 files changed, 48 insertions, 64 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index f580551a5..a4150acb5 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -411,23 +411,11 @@
(define (unary op a)
(op asm (from-sp (slot a)))
(emit-branch emit-je emit-jne))
- (define (binary-test op a b)
- (op asm (from-sp (slot a)) (from-sp (slot b)))
- (emit-branch emit-je emit-jne))
- (define (binary* op emit-jt emit-jf a b)
+ (define (binary op emit-jt emit-jf a b)
(op asm (from-sp (slot a)) (from-sp (slot b)))
(emit-branch emit-jt emit-jf))
- (define (binary op a b)
- (cond
- ((eq? kt next-label)
- (op asm (from-sp (slot a)) (from-sp (slot b)) #t kf))
- ((eq? kf next-label)
- (op asm (from-sp (slot a)) (from-sp (slot b)) #f kt))
- (else
- (let ((invert? (not (prefer-true?))))
- (op asm (from-sp (slot a)) (from-sp (slot b)) invert?
- (if invert? kf kt))
- (emit-j asm (if invert? kt kf))))))
+ (define (binary-test op a b)
+ (binary op emit-je emit-jne a b))
(match exp
(($ $primcall 'heap-object? (a)) (unary emit-heap-object? a))
(($ $primcall 'null? (a)) (unary emit-null? a))
@@ -451,27 +439,26 @@
(($ $primcall 'eq? (a b)) (binary-test emit-eq? a b))
(($ $primcall 'heap-numbers-equal? (a b))
(binary-test emit-heap-numbers-equal? a b))
- (($ $primcall '< (a b)) (binary* emit-<? emit-jl emit-jnl a b))
- (($ $primcall '<= (a b)) (binary* emit-<? emit-jge emit-jnge b a))
+ (($ $primcall '< (a b)) (binary emit-<? emit-jl emit-jnl a b))
+ (($ $primcall '<= (a b)) (binary emit-<? emit-jge emit-jnge b a))
(($ $primcall '= (a b)) (binary-test emit-=? a b))
- (($ $primcall '>= (a b)) (binary* emit-<? emit-jge emit-jnge a b))
- (($ $primcall '> (a b)) (binary* emit-<? emit-jl emit-jnl b a))
- (($ $primcall 'u64-< (a b)) (binary* emit-u64<? emit-jl emit-jnl a b))
- (($ $primcall 'u64-<= (a b)) (binary* emit-u64<? emit-jnl emit-jl b a))
+ (($ $primcall '>= (a b)) (binary emit-<? emit-jge emit-jnge a b))
+ (($ $primcall '> (a b)) (binary emit-<? emit-jl emit-jnl b a))
+ (($ $primcall 'u64-< (a b)) (binary emit-u64<? emit-jl emit-jnl a b))
+ (($ $primcall 'u64-<= (a b)) (binary emit-u64<? emit-jnl emit-jl b a))
(($ $primcall 'u64-= (a b)) (binary-test emit-u64=? a b))
- (($ $primcall 'u64->= (a b)) (binary* emit-u64<? emit-jnl emit-jl a b))
- (($ $primcall 'u64-> (a b)) (binary* emit-u64<? emit-jl emit-jnl b a))
- (($ $primcall 's64-< (a b)) (binary* emit-s64<? emit-jl emit-jnl a b))
- (($ $primcall 's64-<= (a b)) (binary* emit-s64<? emit-jnl emit-jl b a))
+ (($ $primcall 'u64->= (a b)) (binary emit-u64<? emit-jnl emit-jl a b))
+ (($ $primcall 'u64-> (a b)) (binary emit-u64<? emit-jl emit-jnl b a))
+ (($ $primcall 's64-< (a b)) (binary emit-s64<? emit-jl emit-jnl a b))
+ (($ $primcall 's64-<= (a b)) (binary emit-s64<? emit-jnl emit-jl b a))
(($ $primcall 's64-= (a b)) (binary-test emit-s64=? a b))
- (($ $primcall 's64->= (a b)) (binary* emit-s64<? emit-jnl emit-jl a b))
- (($ $primcall 's64-> (a b)) (binary* emit-s64<? emit-jl emit-jnl b a))
- (($ $primcall 'f64-< (a b)) (binary* emit-f64<? emit-jl emit-jnl a b))
- (($ $primcall 'f64-<= (a b)) (binary* emit-f64<? emit-jge emit-jnge b a))
+ (($ $primcall 's64->= (a b)) (binary emit-s64<? emit-jnl emit-jl a b))
+ (($ $primcall 's64-> (a b)) (binary emit-s64<? emit-jl emit-jnl b a))
+ (($ $primcall 'f64-< (a b)) (binary emit-f64<? emit-jl emit-jnl a b))
+ (($ $primcall 'f64-<= (a b)) (binary emit-f64<? emit-jge emit-jnge b a))
(($ $primcall 'f64-= (a b)) (binary-test emit-f64=? a b))
- (($ $primcall 'f64->= (a b)) (binary* emit-f64<? emit-jge emit-jnge a b))
- (($ $primcall 'f64-> (a b)) (binary* emit-f64<? emit-jl emit-jnl b a))
- (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
+ (($ $primcall 'f64->= (a b)) (binary emit-f64<? emit-jge emit-jnge a b))
+ (($ $primcall 'f64-> (a b)) (binary emit-f64<? emit-jl emit-jnl b a))))
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm
index c807472e4..8d07e0d11 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -143,9 +143,6 @@ before it is lowered to CPS?"
f64-<
f64-<=
- ;; FIXME: Expand these.
- logtest
-
;; FIXME: Remove these.
>
>=
diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index 5a79a7b24..8086b0c27 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -184,20 +184,6 @@
(define-branch-folder-alias u64-> >)
(define-branch-folder-alias s64-> >)
-(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
- (define (logand-min a b)
- (if (< a b 0)
- (min a b)
- 0))
- (define (logand-max a b)
- (if (< a b 0)
- 0
- (max a b)))
- (if (and (= min0 max0) (= min1 max1)
- (type<=? (logior type0 type1) &exact-integer))
- (values #t (logtest min0 min1))
- (values #f #f)))
-
@@ -282,6 +268,7 @@
(define-binary-primcall-reducer (logbit? cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
+ ;; FIXME: Use an unboxed number for the mask instead of a fixnum.
(define (convert-to-logtest cps kbool)
(define (compute-mask cps kmask src)
(if (eq? min0 max0)
@@ -293,14 +280,20 @@
(build-term
($continue kmask src ($primcall 'ash (one arg0)))))))))
(with-cps cps
- (letv mask)
+ (letv mask test)
(letk kt ($kargs () ()
($continue kbool src ($const #t))))
(letk kf ($kargs () ()
($continue kbool src ($const #f))))
+ (let$ body (with-cps-constants ((zero 0))
+ (build-term
+ ($continue kt src
+ ($branch kf ($primcall 'eq? (test zero)))))))
+ (letk kand ($kargs (#f) (test)
+ ,body))
(letk kmask ($kargs (#f) (mask)
- ($continue kf src
- ($branch kt ($primcall 'logtest (mask arg1))))))
+ ($continue kand src
+ ($primcall 'logand (mask arg1)))))
($ (compute-mask kmask src))))
;; Hairiness because we are converting from a primcall with unknown
;; arity to a branching primcall.
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index f1948494e..f19addee8 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1476,9 +1476,10 @@ minimum, and maximum."
(- -1 (&min a))))
(define-simple-type-checker (logtest &exact-integer &exact-integer))
-(define-predicate-inferrer (logtest a b true?)
+(define-type-inferrer (logtest a b result)
(restrict! a &exact-integer -inf.0 +inf.0)
- (restrict! b &exact-integer -inf.0 +inf.0))
+ (restrict! b &exact-integer -inf.0 +inf.0)
+ (define! result &special-immediate &false &true))
(define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer))
(define-type-inferrer (logbit? a b result)
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 993fa0ad6..0c23f7b41 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1,6 +1,6 @@
;;; Tree-IL partial evaluator
-;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -1381,19 +1381,25 @@ top-level bindings from ENV and return the resulting expression."
($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
(for-tail (make-const #f #t)))
- (('= ($ <primcall> src2 'logand (a b)) ($ <const> _ 0))
- (let ((src (or src src2)))
- (make-primcall src 'not
- (list (make-primcall src 'logtest (list a b))))))
-
(('logbit? ($ <const> src2
(? (lambda (bit)
- (and (exact-integer? bit) (not (negative? bit))))
+ (and (exact-integer? bit)
+ (<= 0 bit (logcount most-positive-fixnum))))
bit))
val)
- (fold-constants src 'logtest
- (list (make-const (or src2 src) (ash 1 bit)) val)
- ctx))
+ (for-tail
+ (make-primcall src 'logtest
+ (list (make-const src2 (ash 1 bit)) val))))
+
+ (('logtest a b)
+ (for-tail
+ (make-primcall
+ src
+ 'not
+ (list
+ (make-primcall src 'eq?
+ (list (make-primcall src 'logand (list a b))
+ (make-const src 0)))))))
(((? effect-free-primitive?) . args)
(fold-constants src name args ctx))