summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-11-20 16:45:35 +0100
committerAndy Wingo <wingo@pobox.com>2023-11-20 16:45:35 +0100
commitd579848cb5d65440af5afd9c8968628665554c22 (patch)
tree28cd9a07b45faa0e69207b3c7c24c450174631aa /module/language
parent89501a83ceec5ac4d3449e92ba2109fb77448b31 (diff)
downloadguile-d579848cb5d65440af5afd9c8968628665554c22.tar.gz
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.
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/specialize-numbers.scm13
-rw-r--r--module/language/cps/type-fold.scm16
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))))