mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-31 01:10:24 +02:00
Code Activity

Specialize rsh/lsh, not ash

Browse source 
* module/language/cps/specialize-numbers.scm (specialize-operations):
  Replace "ash" specializer with "rsh"/"lsh" specializer.
This commit is contained in:
Andy Wingo 2017-11-11 21:46:35 +01:00
parent 107f70a633
commit 83a03a324b
1 changed files with 7 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

47
module/language/cps/specialize-numbers.scm
View file

@ -483,7 +483,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
types types
sigbits)))))) sigbits))))))
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $primcall 'ash #f (a b)))) ($ $continue k src
($ $primcall (and op (or 'lsh 'rsh)) (a b))))
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $kargs (_) (result)) (($ $kargs (_) (result))
(call-with-values (lambda () (call-with-values (lambda ()
@ -491,47 +492,13 @@ BITS indicating the significant bits needed for a variable. BITS may be
(lambda (b-type b-min b-max) (lambda (b-type b-min b-max)
(values (values
(cond (cond
((or (not (u64-result? result)) ((and (u64-result? result)
(not (u64-operand? a)) (u64-operand? a)
(not (type<=? b-type &exact-integer)) (<= b-max 63))
(< b-min 0 b-max)
(<= b-min -64)
(<= 64 b-max))
cps)
((= b-min b-max)
(if (< b-min 0)
(with-cps cps
(let$ body
(specialize-u64-unop k src
'rsh/immediate a (- b-min)))
(setk label ($kargs names vars ,body)))
(with-cps cps
(let$ body
(specialize-u64-unop k src
'lsh/immediate a b-min))
(setk label ($kargs names vars ,body)))))
((< b-min 0)
(with-cps cps (with-cps cps
(let$ body (let$ body (specialize-u64-shift k src op a b))
(with-cps-constants ((zero 0))
(letv count ucount)
(let$ body
(specialize-u64-shift k src 'rsh a ucount))
(letk kucount ($kargs ('ucount) (ucount) ,body))
(letk kcount ($kargs ('count) (count)
($continue kucount src
($primcall 'scm->u64 #f (count)))))
(build-term ($continue kcount src
($primcall 'sub #f (zero b))))))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
(else (else cps))
(with-cps cps
(letv ucount)
(let$ body (specialize-u64-shift k src 'lsh a ucount))
(letk kunbox ($kargs ('ucount) (ucount) ,body))
(setk label ($kargs names vars
($continue kunbox src
($primcall 'scm->u64 #f (b))))))))
types types
sigbits)))))) sigbits))))))
(($ $kargs names vars (($ $kargs names vars