diff options
author | Andy Wingo <wingo@pobox.com> | 2023-11-20 16:45:35 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2023-11-20 16:45:35 +0100 |
commit | d579848cb5d65440af5afd9c8968628665554c22 (patch) | |
tree | 28cd9a07b45faa0e69207b3c7c24c450174631aa /module/language | |
parent | 89501a83ceec5ac4d3449e92ba2109fb77448b31 (diff) | |
download | guile-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.scm | 13 | ||||
-rw-r--r-- | 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)))) |