Skip to content
Snippets Groups Projects
Commit 48d97225 authored by wlott's avatar wlott
Browse files

Spiffed up ASH derived type optimizer. If the shift amount is reasonably

small, (e.g. (integer 0 15)) it will shift the range of the shiftee to
obtain the domain.

Changed the %ldb transform to map to (logand (ash num (- pos)) (mask size))
if the result is going to be a fixnum.

Added transforms for floor, mod, truncate, and rem that check to see if the
argument is a constant power of 2, and if so, change the divide into a
shift.
parent 67750b4d
No related branches found
No related tags found
No related merge requests found
...@@ -260,16 +260,35 @@ ...@@ -260,16 +260,35 @@
nil)))))))) nil))))))))
(defoptimizer (ash derive-type) ((n shift)) (defoptimizer (ash derive-type) ((n shift))
(let ((type (continuation-type n))) (or (let ((n-type (continuation-type n)))
(if (and (numeric-type-p type) (when (numeric-type-p n-type)
(constant-continuation-p shift)) (let ((n-low (numeric-type-low n-type))
(let ((low (numeric-type-low type)) (n-high (numeric-type-high n-type)))
(high (numeric-type-high type)) (if (constant-continuation-p shift)
(shift (continuation-value shift))) (let ((shift (continuation-value shift)))
(make-numeric-type :class 'integer :complexp :real (make-numeric-type :class 'integer :complexp :real
:low (when low (ash low shift)) :low (when n-low (ash n-low shift))
:high (when high (ash high shift)))) :high (when n-high (ash n-high shift))))
*universal-type*))) (let ((s-type (continuation-type shift)))
(format *trace-output* "~&n-type: ~S~%s-type: ~S~%"
n-type s-type)
(when (numeric-type-p s-type)
(let ((s-low (numeric-type-low s-type))
(s-high (numeric-type-high s-type)))
(let ((new-type
(if (and s-low s-high (<= s-low 32) (<= s-high 32))
(make-numeric-type :class 'integer :complexp :real
:low (when n-low
(min (ash n-low s-high)
(ash n-low s-low)))
:high (when n-high
(max (ash n-high s-high)
(ash n-high s-low))))
(make-numeric-type :class 'integer
:complexp :real))))
(format *trace-output* "new-type: ~S~2%" new-type)
new-type))))))))
*universal-type*))
;;; Negative-Integer-P -- Internal ;;; Negative-Integer-P -- Internal
...@@ -452,10 +471,25 @@ ...@@ -452,10 +471,25 @@
(give-up)) (give-up))
(values size pos))) (values size pos)))
(deftransform %ldb ((size pos int) (t t fixnum)) (defun max-value (cont)
(multiple-value-bind (size pos) (if (constant-continuation-p cont)
(check-fixnum-byte size pos) (continuation-value cont)
`(logand (ash int ,(- pos)) ,(ldb (byte size 0) -1)))) (let ((type (continuation-type cont)))
(or (and (numeric-type-p type)
(numeric-type-high type))
(give-up
"Size is not constant and its upper bound is not known.")))))
(deftransform %ldb ((size pos int) (fixnum fixnum integer))
(let ((size-len (max-value size)))
(unless (<= size-len (integer-length most-positive-fixnum))
(format *trace-output* "~&max-size=~D~%" size-len)
(give-up "result might be up to ~D bits, can't open code %ldb." size-len))
(if (zerop size-len)
0
`(logand (ash int (- pos))
(ash ,(1- (ash 1 (integer-length most-positive-fixnum)))
(- size ,(integer-length most-positive-fixnum)))))))
(deftransform %dpb ((new size pos int) (t t t fixnum)) (deftransform %dpb ((new size pos int) (t t t fixnum))
(multiple-value-bind (size pos) (multiple-value-bind (size pos)
...@@ -532,6 +566,69 @@ ...@@ -532,6 +566,69 @@
`(- (ash x ,len)) `(- (ash x ,len))
`(ash x ,len)))) `(ash x ,len))))
;;; If arg is a constant power of two, turn floor into a shift and mask.
;;;
(deftransform floor ((x y) (integer integer))
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(let ((shift (- len))
(mask (1- y-abs)))
(if (minusp y)
`(values (ash (- x) ,shift)
(- (logand (- x) ,mask)))
`(values (ash x ,shift)
(logand x ,mask))))))
;;; Do the same for mod.
;;;
(deftransform mod ((x y) (integer integer))
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(let ((mask (1- y-abs)))
(if (minusp y)
`(- (logand (- x) ,mask))
`(logand x ,mask)))))
;;; If arg is a constant power of two, turn truncate into a shift and mask.
;;;
(deftransform truncate ((x y) (integer integer))
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(let* ((shift (- len))
(mask (1- y-abs)))
`(if (minusp x)
(values ,(if (minusp y)
`(ash (- x) ,shift)
`(- (ash (- x) ,shift)))
(- (logand (- x) ,mask)))
(values ,(if (minusp y)
`(- (ash (- x) ,shift))
`(ash x ,shift))
(logand x ,mask))))))
;;; And the same for rem.
;;;
(deftransform rem ((x y) (integer integer))
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(let ((mask (1- y-abs)))
`(if (minusp x)
(- (logand (- x) ,mask))
(logand x ,mask)))))
;;;; Character operations: ;;;; Character operations:
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment