From 7e647535b43b692b64f0fe2407ff4f74f83436ac Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Tue, 19 Nov 2019 11:44:46 -0300 Subject: [PATCH] don't fold ash in cp0 when the shift is too big fix also bitwise-arithmetic-shift/-right/-left. primdata.ss, cp0.ss, 5_3.ms original commit: 0b0777912b1aa80cff108dc1d34917bb80875e0b --- mats/5_3.ms | 24 +++++++++++++++--------- s/cp0.ss | 31 +++++++++++++++++++++++++++---- s/primdata.ss | 8 ++++---- 3 files changed, 46 insertions(+), 17 deletions(-) diff --git a/mats/5_3.ms b/mats/5_3.ms index 096715ccb7..722b2dd592 100644 --- a/mats/5_3.ms +++ b/mats/5_3.ms @@ -3069,9 +3069,11 @@ (= (ash 1 -32) 0) (= (ash 1 -33) 0) (= (ash 1 -96) 0) - (= (ash 987239487293874234 -1000) 0) - (= (ash -987239487293874234 -1000) -1) - (let f ([i -1000]) + (= (ash 987239487293874234 -900) 0) + (= (ash 987239487293874234 -1100) 0) + (= (ash -987239487293874234 -900) -1) + (= (ash -987239487293874234 -1100) -1) + (let f ([i -2000]) (or (fx= i 0) (and (negative? (ash -232342342340033477676766821733948948594358 i)) (f (fx+ i 1))))) @@ -3114,9 +3116,11 @@ (= (bitwise-arithmetic-shift 1 -32) 0) (= (bitwise-arithmetic-shift 1 -33) 0) (= (bitwise-arithmetic-shift 1 -96) 0) - (= (bitwise-arithmetic-shift 987239487293874234 -1000) 0) - (= (bitwise-arithmetic-shift -987239487293874234 -1000) -1) - (let f ([i -1000]) + (= (bitwise-arithmetic-shift 987239487293874234 -900) 0) + (= (bitwise-arithmetic-shift 987239487293874234 -1100) 0) + (= (bitwise-arithmetic-shift -987239487293874234 -900) -1) + (= (bitwise-arithmetic-shift -987239487293874234 -1100) -1) + (let f ([i -2000]) (or (fx= i 0) (and (negative? (bitwise-arithmetic-shift -232342342340033477676766821733948948594358 i)) (f (fx+ i 1))))) @@ -3159,9 +3163,11 @@ (= (bitwise-arithmetic-shift-right 1 32) 0) (= (bitwise-arithmetic-shift-right 1 33) 0) (= (bitwise-arithmetic-shift-right 1 96) 0) - (= (bitwise-arithmetic-shift-right 987239487293874234 1000) 0) - (= (bitwise-arithmetic-shift-right -987239487293874234 1000) -1) - (let f ([i -1000]) + (= (bitwise-arithmetic-shift-right 987239487293874234 900) 0) + (= (bitwise-arithmetic-shift-right 987239487293874234 1100) 0) + (= (bitwise-arithmetic-shift-right -987239487293874234 900) -1) + (= (bitwise-arithmetic-shift-right -987239487293874234 1100) -1) + (let f ([i -2000]) (or (fx= i 0) (and (negative? (bitwise-arithmetic-shift-right -232342342340033477676766821733948948594358 (- i))) (f (fx+ i 1))))) diff --git a/s/cp0.ss b/s/cp0.ss index d5eeefefc7..5f362b5a05 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -2408,10 +2408,33 @@ (define-inline 3 (boolean=? symbol=? r6rs:char=? r6rs:char-ci=? r6rs:string=? r6rs:string-ci=?) [(arg1 arg2 . arg*) (handle-equality ctxt arg1 (cons arg2 arg*))]) - (define-inline 3 (ash - bitwise-arithmetic-shift bitwise-arithmetic-shift-left - bitwise-arithmetic-shift-right) - [(x y) (handle-shift 3 ctxt x y)]) + (let () + (define (try-fold-ash-op op ctxt x y) + (let ([xval (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! x)) + [(quote ,d) (and (exact? d) (integer? d) d)] + [else #f])] + [yval (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! y)) + [(quote ,d) (and (fixnum? d) (fx< -1000 d 1000) d)] + [else #f])]) + (and xval + yval + (let ([r (guard (c [#t #f]) (op xval yval))]) + (when r + (residualize-seq '() (list x y) ctxt) + `(quote ,r)))))) + (define-syntax define-inline-ash-op + (syntax-rules () + [(_ op) + (begin + (define-inline 2 op + [(x y) (try-fold-ash-op op ctxt x y)]) + (define-inline 3 op + [(x y) (or (try-fold-ash-op op ctxt x y) + (handle-shift 3 ctxt x y))]))])) + (define-inline-ash-op ash) + (define-inline-ash-op bitwise-arithmetic-shift) + (define-inline-ash-op bitwise-arithmetic-shift-left) + (define-inline-ash-op bitwise-arithmetic-shift-right)) (define-inline 3 fxbit-field ; expose internal fx ops for partial optimization [(?n ?start ?end) diff --git a/s/primdata.ss b/s/primdata.ss index 52a99d71c0..fdd4e41aa6 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -28,9 +28,9 @@ (bitwise-copy-bit [sig [(sint uint bit) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) (bitwise-bit-field [sig [(sint sub-uint sub-uint) -> (uint)]] [flags arith-op mifoldable discard safeongoodargs]) (bitwise-copy-bit-field [sig [(sint sub-uint sub-uint sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) - (bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs]) - (bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs]) - (bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs]) + (bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op discard cp02 cp03 safeongoodargs]) + (bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op discard cp02 cp03 safeongoodargs]) + (bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op discard cp02 cp03 safeongoodargs]) (bitwise-rotate-bit-field [sig [(sint sub-uint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) (bitwise-reverse-bit-field [sig [(sint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) ) @@ -1136,7 +1136,7 @@ (append! [sig [() -> (null)] [(list ... ptr) -> (ptr)]] [flags cp02]) (apropos [sig [(sub-ptr) (sub-ptr environment) -> (void)]] [flags true]) (apropos-list [sig [(sub-ptr) (sub-ptr environment) -> (list)]] [flags alloc]) - (ash [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03]) + (ash [sig [(sint sint) -> (sint)]] [flags arith-op discard cp02 cp03]) ; can take too long to fold (assertion-violationf [sig [(maybe-who string sub-ptr ...) -> (bottom)]] [flags abort-op]) ; 2nd arg is format string (asinh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (atanh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])