-;;; This is essentially a straight implementation of the algorithm in
-;;; "Strength Reduction of Multiplications by Integer Constants",
-;;; Youfeng Wu, ACM SIGPLAN Notices, Vol. 30, No.2, February 1995.
-(defun basic-decompose-multiplication (arg num n-bits condensed)
- (case (aref condensed 0)
- (0
- (let ((tmp (min 3 (aref condensed 1))))
- (decf (aref condensed 1) tmp)
- `(logand #xffffffff
- (%lea ,arg
- ,(decompose-multiplication
- arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1))
- ,(ash 1 tmp) 0))))
- ((1 2 3)
- (let ((r0 (aref condensed 0)))
- (incf (aref condensed 1) r0)
- `(logand #xffffffff
- (%lea ,(decompose-multiplication
- arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1))
- ,arg
- ,(ash 1 r0) 0))))
- (t (let ((r0 (aref condensed 0)))
- (setf (aref condensed 0) 0)
- `(logand #xffffffff
- (ash ,(decompose-multiplication
- arg (ash num (- r0)) n-bits condensed)
- ,r0))))))
-
-(defun decompose-multiplication (arg num n-bits condensed)
- (cond
- ((= n-bits 0) 0)
- ((= num 1) arg)
- ((= n-bits 1)
- `(logand #xffffffff (ash ,arg ,(1- (integer-length num)))))
- ((let ((max 0) (end 0))
- (loop for i from 2 to (length condensed)
- for j = (reduce #'+ (subseq condensed 0 i))
- when (and (> (- (* 2 i) 3 j) max)
- (< (+ (ash 1 (1+ j))
- (ash (ldb (byte (- 64 (1+ j)) (1+ j)) num)
- (1+ j)))
- (ash 1 64)))
- do (setq max (- (* 2 i) 3 j)
- end i))
- (when (> max 0)
- (let ((j (reduce #'+ (subseq condensed 0 end))))
- (let ((n2 (+ (ash 1 (1+ j))
- (ash (ldb (byte (- 64 (1+ j)) (1+ j)) num) (1+ j))))
- (n1 (1+ (ldb (byte (1+ j) 0) (lognot num)))))
- `(logand #xffffffff
- (- ,(optimize-multiply arg n2) ,(optimize-multiply arg n1))))))))
- ((dolist (i '(9 5 3))
- (when (integerp (/ num i))
- (when (< (logcount (/ num i)) (logcount num))
- (let ((x (gensym)))
- (return `(let ((,x ,(optimize-multiply arg (/ num i))))
- (logand #xffffffff
- (%lea ,x ,x (1- ,i) 0)))))))))
- (t (basic-decompose-multiplication arg num n-bits condensed))))
-
-(defun optimize-multiply (arg x)
- (let* ((n-bits (logcount x))
- (condensed (make-array n-bits)))
- (let ((count 0) (bit 0))
- (dotimes (i 64)
- (cond ((logbitp i x)
- (setf (aref condensed bit) count)
- (setf count 1)
- (incf bit))
- (t (incf count)))))
- (decompose-multiplication arg x n-bits condensed)))
-