diff options
author | Andy Wingo <wingo@pobox.com> | 2017-10-30 10:14:48 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-10-30 11:50:45 +0100 |
commit | 0d42f5467f9b0d7841af3043bca7ad53a6c6ee64 (patch) | |
tree | 5d027cc93708fd9f5637eca71c4d3cd51e47987b | |
parent | d1c69b5c9546b04fc5040f3deb2ee0fce0868083 (diff) | |
download | guile-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.scm | 51 | ||||
-rw-r--r-- | module/language/cps/primitives.scm | 3 | ||||
-rw-r--r-- | module/language/cps/type-fold.scm | 27 | ||||
-rw-r--r-- | module/language/cps/types.scm | 5 | ||||
-rw-r--r-- | 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 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)) |