[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/08: Lower logtest branches to instead be 'zero? logan
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/08: Lower logtest branches to instead be 'zero? logand' |
Date: |
Mon, 30 Oct 2017 07:35:33 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 0d42f5467f9b0d7841af3043bca7ad53a6c6ee64
Author: Andy Wingo <address@hidden>
Date: Mon Oct 30 10:14:48 2017 +0100
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 _ _)).
---
module/language/cps/compile-bytecode.scm | 51 ++++++++++++--------------------
module/language/cps/primitives.scm | 3 --
module/language/cps/type-fold.scm | 27 +++++++----------
module/language/cps/types.scm | 5 ++--
module/language/tree-il/peval.scm | 26 +++++++++-------
5 files changed, 48 insertions(+), 64 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index f580551..a4150ac 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 c807472..8d07e0d 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 5a79a7b..8086b0c 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 f194849..f19adde 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 993fa0a..0c23f7b 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))
- [Guile-commits] branch master updated (d1c69b5 -> 4267a8b), Andy Wingo, 2017/10/30
- [Guile-commits] 03/08: Fix argument type of arguments<=? instruction, Andy Wingo, 2017/10/30
- [Guile-commits] 02/08: Remove assembler exports for old-style predicates and branches, Andy Wingo, 2017/10/30
- [Guile-commits] 07/08: RTL test uses new instructions, Andy Wingo, 2017/10/30
- [Guile-commits] 04/08: Emit new instructions in function preludes, Andy Wingo, 2017/10/30
- [Guile-commits] 06/08: Simplify special immediate predicate inferrer., Andy Wingo, 2017/10/30
- [Guile-commits] 01/08: Lower logtest branches to instead be 'zero? logand',
Andy Wingo <=
- [Guile-commits] 05/08: Remove disassembler support for old-style jump instructions, Andy Wingo, 2017/10/30
- [Guile-commits] 08/08: Remove old branching instructions from VM, Andy Wingo, 2017/10/30