From 0d42f5467f9b0d7841af3043bca7ad53a6c6ee64 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 Oct 2017 10:14:48 +0100 Subject: [PATCH] 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 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-= (a b)) (binary* emit- (a b)) (binary* emit-= (a b)) (binary emit- (a b)) (binary emit-= (a b)) (binary* emit-u64 (a b)) (binary* emit-u64= (a b)) (binary emit-u64 (a b)) (binary emit-u64= (a b)) (binary* emit-s64 (a b)) (binary* emit-s64= (a b)) (binary emit-s64 (a b)) (binary emit-s64= (a b)) (binary* emit-f64 (a b)) (binary* emit-f64= (a b)) (binary emit-f64 (a b)) (binary emit-f64 >= 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." ($ _ _ sym) ($ _ _ sym)) (for-tail (make-const #f #t))) - (('= ($ src2 'logand (a b)) ($ _ 0)) - (let ((src (or src src2))) - (make-primcall src 'not - (list (make-primcall src 'logtest (list a b)))))) - (('logbit? ($ 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))