mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +02:00
Code Activity

Fix bug lowering logand/immediate to ulogand/immediate

Browse source 
* module/language/cps/specialize-numbers.scm (logand/immediate): Define
a sigbits handler.
(specialize-operations): Require logand/immediate operand to be u64 to
lower to ulogand/immediate.  Shouldn't be necessary but even if only u64
bits are used, negative fixnums will have the sign bit set, which trips
up further unboxed uses which error if the operand to `scm->u64` is
negative.
* module/language/cps/type-fold.scm (rem): Emit logand/immediate.
This commit is contained in:
Andy Wingo 2023-11-20 16:45:35 +01:00
parent 89501a83ce
commit d579848cb5
2 changed files with 13 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

13
module/language/cps/specialize-numbers.scm
View file

@ -284,18 +284,23 @@
(define significant-bits-handlers (make-hash-table)) (define significant-bits-handlers (make-hash-table))
(define-syntax-rule (define-significant-bits-handler (define-syntax-rule (define-significant-bits-handler
((primop label types out def ...) arg ...) ((primop label types out def ...) param arg ...)
body ...) body ...)
(hashq-set! significant-bits-handlers 'primop (hashq-set! significant-bits-handlers 'primop
(lambda (label types out param args defs) (lambda (label types out param args defs)
(match args ((arg ...) (match defs ((def ...) body ...))))))) (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) (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a)
(inferred-sigbits types label b) (inferred-sigbits types label b)
(intmap-ref out res (lambda (_) 0))))) (intmap-ref out res (lambda (_) 0)))))
(intmap-add (intmap-add out a sigbits sigbits-union) (intmap-add (intmap-add out a sigbits sigbits-union)
b 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) (define (significant-bits-handler primop)
(hashq-ref significant-bits-handlers primop)) (hashq-ref significant-bits-handlers primop))
@ -556,11 +561,11 @@ BITS indicating the significant bits needed for a variable. BITS may be
(specialize-unop cps k src op param a (specialize-unop cps k src op param a
(unbox-u64 a) (box-u64 result)))) (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 (specialize-unop cps k src 'ulogand/immediate
(logand param (1- (ash 1 64))) (logand param (1- (ash 1 64)))
a a
(unbox-u64/truncate a) (box-u64 result))) (unbox-u64 a) (box-u64 result)))
(((or 'add/immediate 'sub/immediate 'mul/immediate) (((or 'add/immediate 'sub/immediate 'mul/immediate)
(? s64-result?) (? s64-parameter?) (? s64-operand? a)) (? s64-result?) (? s64-parameter?) (? s64-operand? a))

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

@ -692,13 +692,9 @@
((and (eqv? type1 &fixnum) (eqv? min1 max1) (power-of-two? min1) ((and (eqv? type1 &fixnum) (eqv? min1 max1) (power-of-two? min1)
(<= 0 min0)) (<= 0 min0))
(with-cps cps (with-cps cps
(letv mask)
(letk kmask
($kargs ('mask) (mask)
($continue k src
($primcall 'logand #f (arg0 mask)))))
(build-term (build-term
($continue kmask src ($const (1- min1)))))) ($continue k src
($primcall 'logand/immediate (1- min1) (arg0))))))
(else (else
(with-cps cps #f)))) (with-cps cps #f))))
@ -710,13 +706,9 @@
(with-cps cps #f)) (with-cps cps #f))
((and (eqv? type1 &fixnum) (eqv? min1 max1) (power-of-two? min1)) ((and (eqv? type1 &fixnum) (eqv? min1 max1) (power-of-two? min1))
(with-cps cps (with-cps cps
(letv mask)
(letk kmask
($kargs ('mask) (mask)
($continue k src
($primcall 'logand #f (arg0 mask)))))
(build-term (build-term
($continue kmask src ($const (1- min1)))))) ($continue k src
($primcall 'logand/immediate (1- min1) (arg0))))))
(else (else
(with-cps cps #f)))) (with-cps cps #f))))