mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +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-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))
@ -556,11 +561,11 @@ BITS indicating the significant bits needed for a variable. BITS may be
(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))

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

@ -692,13 +692,9 @@
((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))))
@ -710,13 +706,9 @@
(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))))