mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-18 18:40:22 +02:00
Code Activity

Lower logtest branches to instead be 'zero? logand'

Browse source 
* 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 _ _)).
This commit is contained in:
Andy Wingo 2017-10-30 10:14:48 +01:00
parent d1c69b5c95
commit 0d42f5467f
5 changed files with 48 additions and 64 deletions
Download patch file Download diff file Expand all files Collapse all files

51
module/language/cps/compile-bytecode.scm
View file

@ -411,23 +411,11 @@
(define (unary op a) (define (unary op a)
(op asm (from-sp (slot a))) (op asm (from-sp (slot a)))
(emit-branch emit-je emit-jne)) (emit-branch emit-je emit-jne))
(define (binary-test op a b) (define (binary op emit-jt emit-jf 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)
(op asm (from-sp (slot a)) (from-sp (slot b))) (op asm (from-sp (slot a)) (from-sp (slot b)))
(emit-branch emit-jt emit-jf)) (emit-branch emit-jt emit-jf))
(define (binary op a b) (define (binary-test op a b)
(cond (binary op emit-je emit-jne a b))
((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))))))
(match exp (match exp
(($ $primcall 'heap-object? (a)) (unary emit-heap-object? a)) (($ $primcall 'heap-object? (a)) (unary emit-heap-object? a))
(($ $primcall 'null? (a)) (unary emit-null? a)) (($ $primcall 'null? (a)) (unary emit-null? a))
@ -451,27 +439,26 @@
(($ $primcall 'eq? (a b)) (binary-test emit-eq? a b)) (($ $primcall 'eq? (a b)) (binary-test emit-eq? a b))
(($ $primcall 'heap-numbers-equal? (a b)) (($ $primcall 'heap-numbers-equal? (a b))
(binary-test emit-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-jl emit-jnl a b))
(($ $primcall '<= (a b)) (binary* emit-<? emit-jge emit-jnge b a)) (($ $primcall '<= (a b)) (binary emit-<? emit-jge emit-jnge b a))
(($ $primcall '= (a b)) (binary-test emit-=? a b)) (($ $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-jge emit-jnge a b))
(($ $primcall '> (a b)) (binary* emit-<? emit-jl emit-jnl b a)) (($ $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-jl emit-jnl a b))
(($ $primcall 'u64-<= (a b)) (binary* emit-u64<? emit-jnl emit-jl b a)) (($ $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-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-jnl emit-jl a b))
(($ $primcall 'u64-> (a b)) (binary* emit-u64<? emit-jl emit-jnl b a)) (($ $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-jl emit-jnl a b))
(($ $primcall 's64-<= (a b)) (binary* emit-s64<? emit-jnl emit-jl b a)) (($ $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-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-jnl emit-jl a b))
(($ $primcall 's64-> (a b)) (binary* emit-s64<? emit-jl emit-jnl b a)) (($ $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-jl emit-jnl a b))
(($ $primcall 'f64-<= (a b)) (binary* emit-f64<? emit-jge emit-jnge b a)) (($ $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-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-jge emit-jnge a b))
(($ $primcall 'f64-> (a b)) (binary* emit-f64<? emit-jl emit-jnl b a)) (($ $primcall 'f64-> (a b)) (binary emit-f64<? emit-jl emit-jnl b a))))
(($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
(define (compile-trunc label k exp nreq rest-var) (define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call) (define (do-call proc args emit-call)

3
module/language/cps/primitives.scm
View file

@ -143,9 +143,6 @@ before it is lowered to CPS?"
f64-< f64-<
f64-<= f64-<=
;; FIXME: Expand these.
logtest
;; FIXME: Remove these. ;; FIXME: Remove these.
> >
>= >=

27
module/language/cps/type-fold.scm
View file

@ -184,20 +184,6 @@
(define-branch-folder-alias u64-> >) (define-branch-folder-alias u64-> >)
(define-branch-folder-alias s64-> >) (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 (define-binary-primcall-reducer (logbit? cps k src
arg0 type0 min0 max0 arg0 type0 min0 max0
arg1 type1 min1 max1) arg1 type1 min1 max1)
;; FIXME: Use an unboxed number for the mask instead of a fixnum.
(define (convert-to-logtest cps kbool) (define (convert-to-logtest cps kbool)
(define (compute-mask cps kmask src) (define (compute-mask cps kmask src)
(if (eq? min0 max0) (if (eq? min0 max0)
@ -293,14 +280,20 @@
(build-term (build-term
($continue kmask src ($primcall 'ash (one arg0))))))))) ($continue kmask src ($primcall 'ash (one arg0)))))))))
(with-cps cps (with-cps cps
(letv mask) (letv mask test)
(letk kt ($kargs () () (letk kt ($kargs () ()
($continue kbool src ($const #t)))) ($continue kbool src ($const #t))))
(letk kf ($kargs () () (letk kf ($kargs () ()
($continue kbool src ($const #f)))) ($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) (letk kmask ($kargs (#f) (mask)
($continue kf src ($continue kand src
($branch kt ($primcall 'logtest (mask arg1)))))) ($primcall 'logand (mask arg1)))))
($ (compute-mask kmask src)))) ($ (compute-mask kmask src))))
;; Hairiness because we are converting from a primcall with unknown ;; Hairiness because we are converting from a primcall with unknown
;; arity to a branching primcall. ;; arity to a branching primcall.

5
module/language/cps/types.scm
View file

@ -1476,9 +1476,10 @@ minimum, and maximum."
(- -1 (&min a)))) (- -1 (&min a))))
(define-simple-type-checker (logtest &exact-integer &exact-integer)) (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! 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-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer))
(define-type-inferrer (logbit? a b result) (define-type-inferrer (logbit? a b result)

26
module/language/tree-il/peval.scm
View file

@ -1,6 +1,6 @@
;;; Tree-IL partial evaluator ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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)) ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
(for-tail (make-const #f #t))) (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 (('logbit? ($ <const> src2
(? (lambda (bit) (? (lambda (bit)
(and (exact-integer? bit) (not (negative? bit)))) (and (exact-integer? bit)
(<= 0 bit (logcount most-positive-fixnum))))
bit)) bit))
val) val)
(fold-constants src 'logtest (for-tail
(list (make-const (or src2 src) (ash 1 bit)) val) (make-primcall src 'logtest
ctx)) (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) (((? effect-free-primitive?) . args)
(fold-constants src name args ctx)) (fold-constants src name args ctx))