wingo pushed a commit to branch main
in repository guile.
commit d579848cb5d65440af5afd9c8968628665554c22
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon Nov 20 16:45:35 2023 +0100
Fix bug lowering logand/immediate to ulogand/immediate
* 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.
---
module/language/cps/specialize-numbers.scm | 13 +++++++++----
module/language/cps/type-fold.scm | 16 ++++------------
2 files changed, 13 insertions(+), 16 deletions(-)
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 12c9deecc..4ec88871c 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -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))
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index a07950d81..63d47db8f 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -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))))
