Revert of https://git.savannah.gnu.org/cgit/guile.git/commit/?id=d579848cb5d65440af5afd9c8968628665554c22 --- b/module/language/cps/specialize-numbers.scm +++ a/module/language/cps/specialize-numbers.scm @@ -284,23 +284,18 @@ (define significant-bits-handlers (make-hash-table)) (define-syntax-rule (define-significant-bits-handler + ((primop label types out def ...) arg ...) - ((primop label types out def ...) param arg ...) body ...) (hashq-set! significant-bits-handlers 'primop (lambda (label types out param args defs) (match args ((arg ...) (match defs ((def ...) body ...))))))) +(define-significant-bits-handler ((logand label types out res) a b) -(define-significant-bits-handler ((logand label types out res) param a b) (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a) (inferred-sigbits types label b) (intmap-ref out res (lambda (_) 0))))) (intmap-add (intmap-add out a sigbits sigbits-union) b sigbits sigbits-union))) -(define-significant-bits-handler ((logand/immediate label types out res) param a) - (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a) - param - (intmap-ref out res (lambda (_) 0))))) - (intmap-add out a sigbits sigbits-union))) (define (significant-bits-handler primop) (hashq-ref significant-bits-handlers primop)) @@ -561,11 +556,11 @@ (specialize-unop cps k src op param a (unbox-u64 a) (box-u64 result)))) + (('logand/immediate (? u64-result? ) param a) - (('logand/immediate (? u64-result? ) param (? u64-operand? a)) (specialize-unop cps k src 'ulogand/immediate (logand param (1- (ash 1 64))) a + (unbox-u64/truncate a) (box-u64 result))) - (unbox-u64 a) (box-u64 result))) (((or 'add/immediate 'sub/immediate 'mul/immediate) (? s64-result?) (? s64-parameter?) (? s64-operand? a)) --- b/module/language/cps/type-fold.scm +++ a/module/language/cps/type-fold.scm @@ -692,9 +692,13 @@ ((and (eqv? type1 &fixnum) (eqv? min1 max1) (power-of-two? min1) (<= 0 min0)) (with-cps cps + (letv mask) + (letk kmask + ($kargs ('mask) (mask) + ($continue k src + ($primcall 'logand #f (arg0 mask))))) (build-term + ($continue kmask src ($const (1- min1)))))) - ($continue k src - ($primcall 'logand/immediate (1- min1) (arg0)))))) (else (with-cps cps #f)))) @@ -706,9 +710,13 @@ (with-cps cps #f)) ((and (eqv? type1 &fixnum) (eqv? min1 max1) (power-of-two? min1)) (with-cps cps + (letv mask) + (letk kmask + ($kargs ('mask) (mask) + ($continue k src + ($primcall 'logand #f (arg0 mask))))) (build-term + ($continue kmask src ($const (1- min1)))))) - ($continue k src - ($primcall 'logand/immediate (1- min1) (arg0)))))) (else (with-cps cps #f))))