("src/compiler/float-tran")
("src/compiler/saptran")
("src/compiler/srctran")
+ ("src/compiler/generic/vm-tran")
("src/compiler/locall")
("src/compiler/dfo")
("src/compiler/checkgen")
("src/compiler/copyprop")
("src/compiler/represent")
- ("src/compiler/generic/vm-tran")
("src/compiler/pack")
("src/compiler/codegen")
("src/compiler/debug")
(values array start end 0))
#!-alpha
-(defun sb!vm::ash-left-constant-mod32 (integer amount)
+(defun sb!vm::ash-left-mod32 (integer amount)
(ldb (byte 32 0) (ash integer amount)))
#!+alpha
-(defun sb!vm::ash-left-constant-mod64 (integer amount)
+(defun sb!vm::ash-left-mod64 (integer amount)
(ldb (byte 64 0) (ash integer amount)))
collect `(prepare-argument ,arg)))))))
(loop for infos being each hash-value of sb!c::*modular-funs*
;; FIXME: We need to process only "toplevel" functions
- unless (eq infos :good)
+ when (listp infos)
do (loop for info in infos
for name = (sb!c::modular-fun-info-name info)
and width = (sb!c::modular-fun-info-width info)
;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more
;;; discussion of this hack. -- CSR, 2003-10-09
#!-alpha
-(defun sb!vm::ash-left-constant-mod32 (integer amount)
+(defun sb!vm::ash-left-mod32 (integer amount)
(etypecase integer
((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
(fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
(bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
#!+alpha
-(defun sb!vm::ash-left-constant-mod64 (integer amount)
+(defun sb!vm::ash-left-mod64 (integer amount)
(etypecase integer
((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount)))
(fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
- (bignum (ldb (byte 64 0)
+ (bignum (ldb (byte 64 0)
(ash (logand integer #xffffffffffffffff) amount)))))
-
(:generator 1
(inst not x res)))
-(defknown ash-left-constant-mod64 (integer (integer 0)) (unsigned-byte 64)
- (foldable flushable movable))
-(define-vop (fast-ash-left-constant-mod64/unsigned=>unsigned
+(define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
- (:translate ash-left-constant-mod64))
+ (:translate ash-left-mod64))
(macrolet
((define-modular-backend (fun &optional constantp)
\f
;;; Modular functions
-;;; hash: name -> { ({(width . fun)}*) | :good }
+;;; For a documentation, see CUT-TO-WIDTH.
+
+;;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
(defvar *modular-funs*
(make-hash-table :test 'eq))
(defun find-modular-version (fun-name width)
(let ((infos (gethash fun-name *modular-funs*)))
- (if (eq infos :good)
- :good
+ (if (listp infos)
(find-if (lambda (item-width) (>= item-width width))
infos
- :key #'modular-fun-info-width))))
+ :key #'modular-fun-info-width)
+ infos)))
(defun %define-modular-fun (name lambda-list prototype width)
(let* ((infos (the list (gethash prototype *modular-funs*)))
(defmacro define-good-modular-fun (name)
(check-type name symbol)
`(%define-good-modular-fun ',name))
+
+(defmacro define-modular-fun-optimizer
+ (name ((&rest lambda-list) &key (width (gensym "WIDTH")))
+ &body body)
+ (check-type name symbol)
+ (dolist (arg lambda-list)
+ (when (member arg lambda-list-keywords)
+ (error "Lambda list keyword ~S is not supported for ~
+ modular function lambda lists." arg)))
+ (with-unique-names (call args)
+ `(setf (gethash ',name *modular-funs*)
+ (lambda (,call ,width)
+ (declare (type basic-combination ,call)
+ (type (integer 0) width))
+ (let ((,args (basic-combination-args ,call)))
+ (when (= (length ,args) ,(length lambda-list))
+ (destructuring-bind ,lambda-list ,args
+ (declare (type lvar ,@lambda-list))
+ ,@body)))))))
(= (double-float-high-bits x) (double-float-high-bits y))))
\f
-;;;; 32-bit operations
+;;;; modular functions
(define-good-modular-fun logand)
(define-good-modular-fun logior)
;;; FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16
+
+#!-alpha
+(progn
+ (defknown sb!vm::ash-left-mod32 (integer (integer 0)) (unsigned-byte 32)
+ (foldable flushable movable))
+ (define-modular-fun-optimizer ash ((integer count) :width width)
+ (when (and (<= width 32)
+ (constant-lvar-p count) ; ?
+ (plusp (lvar-value count)))
+ (cut-to-width integer width)
+ 'sb!vm::ash-left-mod32)))
+#!+alpha
+(progn
+ (defknown sb!vm::ash-left-mod64 (integer (integer 0)) (unsigned-byte 64)
+ (foldable flushable movable))
+ (define-modular-fun-optimizer ash ((integer count) :width width)
+ (when (and (<= width 64)
+ (constant-lvar-p count) ; ?
+ (plusp (lvar-value count)))
+ (cut-to-width integer width)
+ 'sb!vm::ash-left-mod64)))
+
\f
;;; There are two different ways the multiplier can be recoded. The
;;; more obvious is to shift X by the correct amount for each bit set
(declare (type (unsigned-byte 32) num))
(let ((adds 0) (shifts 0)
(result nil) first-one)
- (labels ((tub32 (x) `(logand ,x #xffffffff)) ; uses modular arithmetic
- (add (next-factor)
+ (labels ((add (next-factor)
(setf result
- (tub32
- (if result
- (progn (incf adds) `(+ ,result ,(tub32 next-factor)))
- next-factor)))))
+ (if result
+ (progn (incf adds) `(+ ,result ,next-factor))
+ next-factor))))
(declare (inline add))
(dotimes (bitpos 32)
(if first-one
(progn
(incf adds)
(incf shifts 2)
- `(- ,(tub32 `(ash ,arg ,bitpos))
- ,(tub32 `(ash ,arg ,first-one))))))
+ `(- (ash ,arg ,bitpos)
+ (ash ,arg ,first-one)))))
(setf first-one nil))
(when (logbitp bitpos num)
(setf first-one bitpos))))
(t
(incf shifts 2)
(incf adds)
- (add `(- ,(tub32 `(ash ,arg 31))
- ,(tub32 `(ash ,arg ,first-one))))))
+ (add `(- (ash ,arg 31)
+ (ash ,arg ,first-one)))))
(incf shifts)
(add `(ash ,arg 31))))
- (values result adds shifts)))
+ (values (if (plusp adds)
+ `(logand ,result #.(1- (ash 1 32))) ; using modular arithmetic
+ result)
+ adds
+ shifts)))
(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
(:translate --mod32))
-(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32)
- (foldable flushable movable))
-(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned
+(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
- (:translate ash-left-constant-mod32))
+ (:translate ash-left-mod32))
(define-modular-fun lognot-mod32 (x) lognot 32)
(define-vop (lognot-mod32/unsigned=>unsigned)
(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
(:translate --mod32))
-(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32)
- (foldable flushable movable))
-(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned
+(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
- (:translate ash-left-constant-mod32))
+ (:translate ash-left-mod32))
;;; logical operations
(define-modular-fun lognot-mod32 (x) lognot 32)
(:generator 1
(inst not res x)))
-(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32)
- (foldable flushable movable))
-(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned
+(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
- (:translate ash-left-constant-mod32))
+ (:translate ash-left-mod32))
(macrolet
((define-modular-backend (fun &optional constantp)
(define-source-transform lognor (x y)
`(lognot (logior ,x ,y)))
-(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32)
- (foldable flushable movable))
-(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned
+(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
- (:translate ash-left-constant-mod32))
+ (:translate ash-left-mod32))
\f
;;;; Binary conditional VOPs:
;;; "goodness" means that the result will not increase (in the
;;; (unsigned-byte +infinity) sense). An ordinary modular function is
;;; replaced with the version, cutting its result to WIDTH or more
-;;; bits. If we have changed anything, we need to flush old derived
-;;; types, because they have nothing in common with the new code.
+;;; bits. For most functions (e.g. for +) we cut all arguments; for
+;;; others (e.g. for ASH) we have "optimizers", cutting only necessary
+;;; arguments (maybe to a different width) and returning the name of a
+;;; modular version, if it exists, or NIL. If we have changed
+;;; anything, we need to flush old derived types, because they have
+;;; nothing in common with the new code.
(defun cut-to-width (lvar width)
(declare (type lvar lvar) (type (integer 0) width))
(labels ((reoptimize-node (node name)
(fun-info-p (basic-combination-kind node)))
(let* ((fun-ref (lvar-use (combination-fun node)))
(fun-name (leaf-source-name (ref-leaf fun-ref)))
- (modular-fun (find-modular-version fun-name width))
- (name (and (modular-fun-info-p modular-fun)
- (modular-fun-info-name modular-fun))))
- (cond
- ((and modular-fun
- (not (and (eq name 'logand)
- (csubtypep
- (single-value-type (node-derived-type node))
- (specifier-type `(unsigned-byte ,width))))))
- (unless (eq modular-fun :good)
- (setq did-something t)
- (change-ref-leaf
- fun-ref
- (find-free-fun name "in a strange place"))
- (setf (combination-kind node) :full))
- (dolist (arg (basic-combination-args node))
- (when (cut-lvar arg)
- (setq did-something t)))
- (when did-something
- (reoptimize-node node fun-name))
- did-something)
- ;; FIXME: This clause is a workaround for a fairly
- ;; critical bug. Prior to this, strength reduction
- ;; of constant (unsigned-byte 32) multiplication
- ;; achieved modular arithmetic by lying to the
- ;; compiler with TRULY-THE. Since we now have an
- ;; understanding of modular arithmetic, we can stop
- ;; lying to the compiler, at the cost of
- ;; uglification of this code. Probably we want to
- ;; generalize the modular arithmetic mechanism to
- ;; be able to deal with more complex operands (ASH,
- ;; EXPT, ...?) -- CSR, 2003-10-09
- ((and
- (eq fun-name 'ash)
- ;; FIXME: only constants for now, but this
- ;; complicates implementation of the out of line
- ;; version of modular ASH. -- CSR, 2003-10-09
- (constant-lvar-p (second (basic-combination-args node)))
- (> (lvar-value (second (basic-combination-args node))) 0))
- (setq did-something t)
- (change-ref-leaf
- fun-ref
- (find-free-fun
- #!-alpha 'sb!vm::ash-left-constant-mod32
- #!+alpha 'sb!vm::ash-left-constant-mod64
- "in a strange place"))
- (setf (combination-kind node) :full)
- (cut-lvar (first (basic-combination-args node)))
- (reoptimize-node node 'ash))))))
+ (modular-fun (find-modular-version fun-name width)))
+ (when (and modular-fun
+ (not (and (eq fun-name 'logand)
+ (csubtypep
+ (single-value-type (node-derived-type node))
+ (specifier-type `(unsigned-byte ,width))))))
+ (binding* ((name (etypecase modular-fun
+ ((eql :good) fun-name)
+ (modular-fun-info
+ (modular-fun-info-name modular-fun))
+ (function
+ (funcall modular-fun node width)))
+ :exit-if-null))
+ (unless (eql modular-fun :good)
+ (setq did-something t)
+ (change-ref-leaf
+ fun-ref
+ (find-free-fun name "in a strange place"))
+ (setf (combination-kind node) :full))
+ (unless (functionp modular-fun)
+ (dolist (arg (basic-combination-args node))
+ (when (cut-lvar arg)
+ (setq did-something t))))
+ (when did-something
+ (reoptimize-node node name))
+ did-something)))))
(cut-lvar (lvar &aux did-something)
(do-uses (node lvar)
(when (cut-node node)
(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
(:translate --mod32))
-(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32)
- (foldable flushable movable))
-(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned
- fast-ash-c/unsigned=>unsigned)
- (:translate ash-left-constant-mod32))
+(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
+ fast-ash-c/unsigned=>unsigned)
+ (:translate ash-left-mod32))
;;; logical operations
(define-modular-fun lognot-mod32 (x) lognot 32)
(let* ((x (random most-positive-fixnum))
(x2 (* x 2))
(x3 (* x 3)))
- (let ((fn (handler-bind (;; broken by rearrangement of
- ;; multiplication strength reduction in
- ;; sbcl-0.8.4.12
- #+nil
- (sb-ext:compiler-note #'error))
+ (let ((fn (handler-bind ((sb-ext:compiler-note
+ (lambda (c)
+ (when (<= x3 most-positive-fixnum)
+ (error c)))))
(compile nil
`(lambda (y)
(declare (optimize speed) (type (integer 0 3) y))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.4.14"
+"0.8.4.15"
projects / sbcl.git / commitdiff