mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 08:40:19 +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)
(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)