* Merged sbcl-0-8-17-28-signed-modular branch.
(defun sb!xc:deposit-field (new cross-byte int)
(cl:deposit-field new (uncross-byte cross-byte) int))
+(defun sb!c::mask-signed-field (size integer)
+ (if (logbitp (1- size) integer)
+ (dpb integer (byte size 0) -1)
+ (ldb (byte size 0) integer)))
+
(define-setf-expander sb!xc:ldb (cross-byte int &environment env)
(multiple-value-bind (temps vals stores store-form access-form)
(get-setf-expansion int env)
(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand newbyte mask)
(logand integer (lognot mask)))))
+
+(defun sb!c::mask-signed-field (size integer)
+ #!+sb-doc
+ "Extract SIZE lower bits from INTEGER, considering them as a
+2-complement SIZE-bits representation of a signed integer."
+ (cond ((zerop size)
+ 0)
+ ((logbitp (1- size) integer)
+ (dpb integer (byte size 0) -1))
+ (t
+ (ldb (byte size 0) integer))))
+
\f
;;;; BOOLE
(bignum (logand x ,pattern)))))
(,name ,@(loop for arg in lambda-list
collect `(prepare-argument ,arg)))))))
- (loop for infos being each hash-value of sb!c::*modular-funs*
+ (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*unsigned-modular-class*)
;; FIXME: We need to process only "toplevel" functions
when (listp infos)
do (loop for info in infos
do (forms (definition name lambda-list width pattern)))))
`(progn ,@(forms)))
+#.
+(collect ((forms))
+ (flet ((definition (name lambda-list width)
+ `(defun ,name ,lambda-list
+ (flet ((prepare-argument (x)
+ (declare (integer x))
+ (etypecase x
+ ((signed-byte ,width) x)
+ (fixnum (sb!c::mask-signed-field ,width x))
+ (bignum (sb!c::mask-signed-field ,width x)))))
+ (,name ,@(loop for arg in lambda-list
+ collect `(prepare-argument ,arg)))))))
+ (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
+ ;; FIXME: We need to process only "toplevel" functions
+ 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)
+ and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+ do (forms (definition name lambda-list width)))))
+ `(progn ,@(forms)))
+
;;; KLUDGE: these out-of-line definitions can't use the modular
;;; arithmetic, as that is only (currently) defined for constant
;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more
(fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
(bignum (ldb (byte 64 0)
(ash (logand integer #xffffffffffffffff) amount)))))
+
+#!+x86
+(defun sb!vm::ash-left-smod30 (integer amount)
+ (etypecase integer
+ ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
+ (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))
(count-low-order-zeros (lvar-uses thing))))
(combination
(case (let ((name (lvar-fun-name (combination-fun thing))))
- (or (modular-version-info name) name))
+ (or (modular-version-info name :unsigned) name))
((+ -)
(let ((min most-positive-fixnum)
(itype (specifier-type 'integer)))
(give-up-ir1-transform))
(let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
(multiple-value-bind (prototype width)
- (modular-version-info inside-fun-name)
+ (modular-version-info inside-fun-name :unsigned)
(unless (eq (or prototype inside-fun-name) 'ash)
(give-up-ir1-transform))
(when (and width (not (constant-lvar-p amount)))
(inst mulq x y r)))
\f
;;;; Modular functions:
-(define-modular-fun lognot-mod64 (x) lognot 64)
+(define-modular-fun lognot-mod64 (x) lognot :unsigned 64)
(define-vop (lognot-mod64/unsigned=>unsigned)
(:translate lognot-mod64)
(:args (x :scs (unsigned-reg)))
(vop (symbolicate 'fast- fun '/unsigned=>unsigned))
(cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
`(progn
- (define-modular-fun ,mfun-name (x y) ,fun 64)
+ (define-modular-fun ,mfun-name (x y) ,fun :unsigned 64)
(define-vop (,modvop ,vop)
(:translate ,mfun-name))
,@(when constantp
;;;; miscellaneous extensions
(defknown get-bytes-consed () unsigned-byte (flushable))
+(defknown mask-signed-field ((integer 0 *) integer) integer
+ (movable flushable foldable))
;;; PCOUNTERs
(defknown incf-pcounter (pcounter unsigned-byte) pcounter)
;;; For a documentation, see CUT-TO-WIDTH.
-;;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
-(defvar *modular-funs*
- (make-hash-table :test 'eq))
+(defstruct modular-class
+ ;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
+ (funs (make-hash-table :test 'eq))
+ ;; hash: modular-variant -> (prototype width)
+ ;;
+ ;; FIXME: Reimplement with generic function names of kind
+ ;; (MODULAR-VERSION prototype width)
+ (versions (make-hash-table :test 'eq))
+ ;; list of increasing widths
+ (widths nil))
+(defvar *unsigned-modular-class* (make-modular-class))
+(defvar *signed-modular-class* (make-modular-class))
+(defun find-modular-class (kind)
+ (ecase kind
+ (:unsigned *unsigned-modular-class*)
+ (:signed *signed-modular-class*)))
-;;; hash: modular-variant -> (prototype width)
-;;;
-;;; FIXME: Reimplement with generic function names of kind
-;;; (MODULAR-VERSION prototype width)
-(defvar *modular-versions* (make-hash-table :test 'eq))
-
-;;; List of increasing widths
-(defvar *modular-funs-widths* nil)
(defstruct modular-fun-info
(name (missing-arg) :type symbol)
(width (missing-arg) :type (integer 0))
(lambda-list (missing-arg) :type list)
(prototype (missing-arg) :type symbol))
-(defun find-modular-version (fun-name width)
- (let ((infos (gethash fun-name *modular-funs*)))
+(defun find-modular-version (fun-name class width)
+ (let ((infos (gethash fun-name (modular-class-funs (find-modular-class class)))))
(if (listp infos)
(find-if (lambda (item-width) (>= item-width width))
infos
infos)))
;;; Return (VALUES prototype-name width)
-(defun modular-version-info (name)
- (values-list (gethash name *modular-versions*)))
+(defun modular-version-info (name class)
+ (values-list (gethash name (modular-class-versions (find-modular-class class)))))
-(defun %define-modular-fun (name lambda-list prototype width)
- (let* ((infos (the list (gethash prototype *modular-funs*)))
+(defun %define-modular-fun (name lambda-list prototype class width)
+ (let* ((class (find-modular-class class))
+ (funs (modular-class-funs class))
+ (versions (modular-class-versions class))
+ (infos (the list (gethash prototype funs)))
(info (find-if (lambda (item-width) (= item-width width))
infos
:key #'modular-fun-info-width)))
(setf (modular-fun-info-name info) name)
(style-warn "Redefining modular version ~S of ~S for width ~S."
name prototype width))
- (setf (gethash prototype *modular-funs*)
+ (setf (gethash prototype funs)
(merge 'list
(list (make-modular-fun-info :name name
:width width
:prototype prototype))
infos
#'< :key #'modular-fun-info-width)
- (gethash name *modular-versions*)
- (list prototype width))))
- (setq *modular-funs-widths*
- (merge 'list (list width) *modular-funs-widths* #'<)))
+ (gethash name versions)
+ (list prototype width)))
+ (setf (modular-class-widths class)
+ (merge 'list (list width) (modular-class-widths class) #'<))))
-(defmacro define-modular-fun (name lambda-list prototype width)
+(defmacro define-modular-fun (name lambda-list prototype class width)
(check-type name symbol)
(check-type prototype symbol)
+ (check-type class (member :unsigned :signed))
(check-type width unsigned-byte)
(dolist (arg lambda-list)
(when (member arg lambda-list-keywords)
(error "Lambda list keyword ~S is not supported for ~
modular function lambda lists." arg)))
`(progn
- (%define-modular-fun ',name ',lambda-list ',prototype ,width)
+ (%define-modular-fun ',name ',lambda-list ',prototype ',class ,width)
(defknown ,name ,(mapcar (constantly 'integer) lambda-list)
- (unsigned-byte ,width)
- (foldable flushable movable))))
+ (,(ecase class
+ (:unsigned 'unsigned-byte)
+ (:signed 'signed-byte))
+ ,width)
+ (foldable flushable movable)
+ :derive-type (make-modular-fun-type-deriver
+ ',prototype ',class ,width))))
-(defun %define-good-modular-fun (name)
- (setf (gethash name *modular-funs*) :good)
+(defun %define-good-modular-fun (name class)
+ (setf (gethash name (modular-class-funs (find-modular-class class))) :good)
name)
-(defmacro define-good-modular-fun (name)
+(defmacro define-good-modular-fun (name class)
(check-type name symbol)
- `(%define-good-modular-fun ',name))
+ (check-type class (member :unsigned :signed))
+ `(%define-good-modular-fun ',name ',class))
(defmacro define-modular-fun-optimizer
- (name ((&rest lambda-list) &key (width (gensym "WIDTH")))
+ (name ((&rest lambda-list) class &key (width (gensym "WIDTH")))
&body body)
(check-type name symbol)
+ (check-type class (member :unsigned :signed))
(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*)
+ `(setf (gethash ',name (modular-class-funs (find-modular-class ',class)))
(lambda (,call ,width)
(declare (type basic-combination ,call)
(type (integer 0) width))
\f
;;;; modular functions
-(define-good-modular-fun logand)
-(define-good-modular-fun logior)
+(define-good-modular-fun logand :unsigned)
+(define-good-modular-fun logior :unsigned)
;;; FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16
(macrolet
- ((def (name width)
+ ((def (name class width)
+ (let ((type (ecase class
+ (:unsigned 'unsigned-byte)
+ (:signed 'signed-byte))))
`(progn
- (defknown ,name (integer (integer 0)) (unsigned-byte ,width)
- (foldable flushable movable))
- (define-modular-fun-optimizer ash ((integer count) :width width)
+ (defknown ,name (integer (integer 0)) (,type ,width)
+ (foldable flushable movable))
+ (define-modular-fun-optimizer ash ((integer count) ,class :width width)
(when (and (<= width ,width)
(or (and (constant-lvar-p count)
(plusp (lvar-value count)))
(csubtypep (lvar-type count)
- (specifier-type '(and unsigned-byte
- fixnum)))))
- (cut-to-width integer width)
+ (specifier-type '(and unsigned-byte fixnum)))))
+ (cut-to-width integer ,class width)
',name))
- (setf (gethash ',name *modular-versions*) `(ash ,',width)))))
+ (setf (gethash ',name (modular-class-versions (find-modular-class ',class)))
+ `(ash ,',width))))))
;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
;; don't have a true Alpha64 port yet, we'll have to stick to
;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
#!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
- (def sb!vm::ash-left-mod32 32)
+ (progn
+ #!+x86 (def sb!vm::ash-left-smod30 :signed 30)
+ (def sb!vm::ash-left-mod32 :unsigned 32))
#!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
- (def sb!vm::ash-left-mod64 64))
+ (def sb!vm::ash-left-mod64 :unsigned 64))
\f
;;;; word-wise logical operations
\f
;;;; modular functions
-(define-modular-fun +-mod32 (x y) + 32)
+(define-modular-fun +-mod32 (x y) + :unsigned 32)
(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
(:translate +-mod32))
(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
(:translate +-mod32))
-(define-modular-fun --mod32 (x y) - 32)
+(define-modular-fun --mod32 (x y) - :unsigned 32)
(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
(:translate --mod32))
(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
(sb!c::give-up-ir1-transform))
'(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
(define-vop (lognot-mod32/unsigned=>unsigned)
(:translate lognot-mod32)
(:args (x :scs (unsigned-reg)))
(modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
(vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
`(progn
- (define-modular-fun ,mfun-name (x y) ,fun 32)
+ (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
(define-vop (,modvop ,vop)
(:translate ,mfun-name))))))
(define-modular-backend logxor)
(defun assert-lvar-type (lvar type policy)
(declare (type lvar lvar) (type ctype type))
(unless (values-subtypep (lvar-derived-type lvar) type)
- (let* ((dest (lvar-dest lvar))
- (ctran (node-prev dest)))
- (with-ir1-environment-from-node dest
- (let* ((cast (make-cast lvar type policy))
- (internal-lvar (make-lvar))
- (internal-ctran (make-ctran)))
- (setf (ctran-next ctran) cast
- (node-prev cast) ctran)
- (use-continuation cast internal-ctran internal-lvar)
- (link-node-to-previous-ctran dest internal-ctran)
- (substitute-lvar internal-lvar lvar)
- (setf (lvar-dest lvar) cast)
- (reoptimize-lvar lvar)
- (when (return-p dest)
- (node-ends-block cast))
- (setf (block-attributep (block-flags (node-block cast))
- type-check type-asserted)
- t))))))
+ (let ((internal-lvar (make-lvar))
+ (dest (lvar-dest lvar)))
+ (substitute-lvar internal-lvar lvar)
+ (let ((cast (insert-cast-before dest lvar type policy)))
+ (use-lvar cast internal-lvar))))
+ (values))
\f
;;;; IR1-OPTIMIZE
t))
(eq (node-home-lambda ref)
(lambda-home (lambda-var-home var))))
+ (let ((ref-type (single-value-type (node-derived-type ref))))
+ (cond ((csubtypep (single-value-type (lvar-type arg)) ref-type)
+ (substitute-lvar-uses lvar arg
+ ;; Really it is (EQ (LVAR-USES LVAR) REF):
+ t)
+ (delete-lvar-use ref))
+ (t
+ (let* ((value (make-lvar))
+ (cast (insert-cast-before ref value ref-type
+ ;; KLUDGE: it should be (TYPE-CHECK 0)
+ *policy*)))
+ (setf (cast-type-to-check cast) *wild-type*)
+ (substitute-lvar-uses value arg
+ ;; FIXME
+ t)
+ (%delete-lvar-use ref)
+ (add-lvar-use cast lvar)))))
(setf (node-derived-type ref) *wild-type*)
- (substitute-lvar-uses lvar arg
- ;; Really it is (EQ (LVAR-USES LVAR) REF):
- t)
- (delete-lvar-use ref)
(change-ref-leaf ref (find-constant nil))
(delete-ref ref)
(unlink-node ref)
(merge-tail-sets merge)))))
(t (flush-dest value)
(unlink-node node))))
+
+;;; Make a CAST and insert it into IR1 before node NEXT.
+(defun insert-cast-before (next lvar type policy)
+ (declare (type node next) (type lvar lvar) (type ctype type))
+ (with-ir1-environment-from-node next
+ (let* ((ctran (node-prev next))
+ (cast (make-cast lvar type policy))
+ (internal-ctran (make-ctran)))
+ (setf (ctran-next ctran) cast
+ (node-prev cast) ctran)
+ (use-ctran cast internal-ctran)
+ (link-node-to-previous-ctran next internal-ctran)
+ (setf (lvar-dest lvar) cast)
+ (reoptimize-lvar lvar)
+ (when (return-p next)
+ (node-ends-block cast))
+ (setf (block-attributep (block-flags (node-block cast))
+ type-check type-asserted)
+ t)
+ cast)))
\f
;;;; miscellaneous shorthand functions
(inst sll r num amount)))))
\f
;;;; Modular arithmetic
-(define-modular-fun +-mod32 (x y) + 32)
+(define-modular-fun +-mod32 (x y) + :unsigned 32)
(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
(:translate +-mod32))
(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
(:translate +-mod32))
-(define-modular-fun --mod32 (x y) - 32)
+(define-modular-fun --mod32 (x y) - :unsigned 32)
(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
(:translate --mod32))
(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
'(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
;;; logical operations
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
(define-vop (lognot-mod32/unsigned=>unsigned)
(:translate lognot-mod32)
(:args (x :scs (unsigned-reg)))
(:generator 1
(inst nor r x zero-tn)))
-(define-modular-fun logxor-mod32 (x y) logxor 32)
+(define-modular-fun logxor-mod32 (x y) logxor :unsigned 32)
(define-vop (fast-logxor-mod32/unsigned=>unsigned
fast-logxor/unsigned=>unsigned)
(:translate logxor-mod32))
fast-logxor-c/unsigned=>unsigned)
(:translate logxor-mod32))
-(define-modular-fun lognor-mod32 (x y) lognor 32)
+(define-modular-fun lognor-mod32 (x y) lognor :unsigned 32)
(define-vop (fast-lognor-mod32/unsigned=>unsigned
fast-lognor/unsigned=>unsigned)
(:translate lognor-mod32))
\f
;;;; Modular functions:
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
(define-vop (lognot-mod32/unsigned=>unsigned)
(:translate lognot-mod32)
(:args (x :scs (unsigned-reg)))
(vop (symbolicate 'fast- fun '/unsigned=>unsigned))
(cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
`(progn
- (define-modular-fun ,mfun-name (x y) ,fun 32)
+ (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
(define-vop (,modvop ,vop)
(:translate ,mfun-name))
,@(when constantp
\f
;;;; Modular functions:
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
(define-vop (lognot-mod32/unsigned=>unsigned)
(:translate lognot-mod32)
(:args (x :scs (unsigned-reg)))
(vop (symbolicate 'fast- fun '/unsigned=>unsigned))
(cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
`(progn
- (define-modular-fun ,mfun-name (x y) ,fun 32)
+ (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
(define-vop (,modvop ,vop)
(:translate ,mfun-name))
,@(when constantp
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
+
+(defoptimizer (mask-signed-field derive-type) ((size x))
+ (let ((size (lvar-type size)))
+ (if (numeric-type-p size)
+ (let ((size-high (numeric-type-high size)))
+ (if (and size-high (<= 1 size-high sb!vm:n-word-bits))
+ (specifier-type `(signed-byte ,size-high))
+ *universal-type*))
+ *universal-type*)))
+
\f
;;; Modular functions
;;;
;;; and similar for other arguments.
+(defun make-modular-fun-type-deriver (prototype class width)
+ #!-sb-fluid
+ (binding* ((info (info :function :info prototype) :exit-if-null)
+ (fun (fun-info-derive-type info) :exit-if-null)
+ (mask-type (specifier-type
+ (ecase class
+ (:unsigned `(unsigned-byte* ,width))
+ (:signed `(signed-byte ,width))))))
+ (lambda (call)
+ (let ((res (funcall fun call)))
+ (when res
+ (if (eq class :unsigned)
+ (logand-derive-type-aux res mask-type))))))
+ #!+sb-fluid
+ (lambda (call)
+ (binding* ((info (info :function :info prototype) :exit-if-null)
+ (fun (fun-info-derive-type info) :exit-if-null)
+ (res (funcall fun call) :exit-if-null)
+ (mask-type (specifier-type
+ (ecase class
+ (:unsigned `(unsigned-byte* ,width))
+ (:signed `(signed-byte ,width))))))
+ (if (eq class :unsigned)
+ (logand-derive-type-aux res mask-type)))))
+
;;; Try to recursively cut all uses of LVAR to WIDTH bits.
;;;
;;; For good functions, we just recursively cut arguments; their
;;; 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)
+(defun cut-to-width (lvar class width)
(declare (type lvar lvar) (type (integer 0) width))
- (labels ((reoptimize-node (node name)
- (setf (node-derived-type node)
- (fun-type-returns
- (info :function :type name)))
- (setf (lvar-%derived-type (node-lvar node)) nil)
- (setf (node-reoptimize node) t)
- (setf (block-reoptimize (node-block node)) t)
- (reoptimize-component (node-component node) :maybe))
- (cut-node (node &aux did-something)
- (when (and (not (block-delete-p (node-block node)))
- (combination-p node)
- (eq (basic-combination-kind node) :known))
- (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)))
- (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)
- (setq did-something t)))
- did-something))
- (cut-lvar lvar)))
+ (let ((type (specifier-type (if (zerop width)
+ '(eql 0)
+ `(,(ecase class (:unsigned 'unsigned-byte)
+ (:signed 'signed-byte))
+ ,width)))))
+ (labels ((reoptimize-node (node name)
+ (setf (node-derived-type node)
+ (fun-type-returns
+ (info :function :type name)))
+ (setf (lvar-%derived-type (node-lvar node)) nil)
+ (setf (node-reoptimize node) t)
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe))
+ (cut-node (node &aux did-something)
+ (when (and (not (block-delete-p (node-block node)))
+ (combination-p node)
+ (eq (basic-combination-kind node) :known))
+ (let* ((fun-ref (lvar-use (combination-fun node)))
+ (fun-name (leaf-source-name (ref-leaf fun-ref)))
+ (modular-fun (find-modular-version fun-name class width)))
+ (when (and modular-fun
+ (not (and (eq fun-name 'logand)
+ (csubtypep
+ (single-value-type (node-derived-type node))
+ type))))
+ (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)
+ (setq did-something t)))
+ did-something))
+ (cut-lvar lvar))))
(defoptimizer (logand optimizer) ((x y) node)
(let ((result-type (single-value-type (node-derived-type node))))
(>= low 0))
(let ((width (integer-length high)))
(when (some (lambda (x) (<= width x))
- *modular-funs-widths*)
+ (modular-class-widths *unsigned-modular-class*))
;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
- (cut-to-width x width)
- (cut-to-width y width)
+ (cut-to-width x :unsigned width)
+ (cut-to-width y :unsigned width)
+ nil ; After fixing above, replace with T.
+ )))))))
+
+(defoptimizer (mask-signed-field optimizer) ((width x) node)
+ (let ((result-type (single-value-type (node-derived-type node))))
+ (when (numeric-type-p result-type)
+ (let ((low (numeric-type-low result-type))
+ (high (numeric-type-high result-type)))
+ (when (and (numberp low) (numberp high))
+ (let ((width (max (integer-length high) (integer-length low))))
+ (when (some (lambda (x) (<= width x))
+ (modular-class-widths *signed-modular-class*))
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
+ (cut-to-width x :signed width)
nil ; After fixing above, replace with T.
)))))))
\f
(give-up-ir1-transform))
'x))
+(deftransform mask-signed-field ((size x) ((constant-arg t) *) *)
+ "fold identity operation"
+ (let ((size (lvar-value size)))
+ (unless (csubtypep (lvar-type x) (specifier-type `(signed-byte ,size)))
+ (give-up-ir1-transform))
+ 'x))
+
;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
;;; (* 0 -4.0) is -0.0.
(deftransform - ((x y) ((constant-arg (member 0)) rational) *)
\f
;;;; Modular functions
-(define-modular-fun +-mod64 (x y) + 64)
+(define-modular-fun +-mod64 (x y) + :unsigned 64)
(define-vop (fast-+-mod64/unsigned=>unsigned fast-+/unsigned=>unsigned)
(:translate +-mod64))
(define-vop (fast-+-mod64-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
(:translate +-mod64))
-(define-modular-fun --mod64 (x y) - 64)
+(define-modular-fun --mod64 (x y) - :unsigned 64)
(define-vop (fast---mod64/unsigned=>unsigned fast--/unsigned=>unsigned)
(:translate --mod64))
(define-vop (fast---mod64-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
(:translate --mod64))
-(define-modular-fun *-mod64 (x y) * 64)
+(define-modular-fun *-mod64 (x y) * :unsigned 64)
(define-vop (fast-*-mod64/unsigned=>unsigned fast-*/unsigned=>unsigned)
(:translate *-mod64))
;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
(unsigned-byte 64)
(foldable flushable movable))
-(define-modular-fun-optimizer %lea ((base index scale disp) :width width)
+(define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
(when (and (<= width 64)
(constant-lvar-p scale)
(constant-lvar-p disp))
(:translate %lea-mod64))
;;; logical operations
-(define-modular-fun lognot-mod64 (x) lognot 64)
+(define-modular-fun lognot-mod64 (x) lognot :unsigned 64)
(define-vop (lognot-mod64/unsigned=>unsigned)
(:translate lognot-mod64)
(:args (x :scs (unsigned-reg unsigned-stack) :target r
(move r x)
(inst not r)))
-(define-modular-fun logxor-mod64 (x y) logxor 64)
+(define-modular-fun logxor-mod64 (x y) logxor :unsigned 64)
(define-vop (fast-logxor-mod64/unsigned=>unsigned
fast-logxor/unsigned=>unsigned)
(:translate logxor-mod64))
\f
;;;; Modular functions
-(define-modular-fun +-mod32 (x y) + 32)
-(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
- (:translate +-mod32))
-(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
- (:translate +-mod32))
-(define-modular-fun --mod32 (x y) - 32)
-(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
- (:translate --mod32))
-(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
- (:translate --mod32))
-
-(define-modular-fun *-mod32 (x y) * 32)
-(define-vop (fast-*-mod32/unsigned=>unsigned fast-*/unsigned=>unsigned)
- (:translate *-mod32))
-;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
+(macrolet ((def (name -c-p)
+ (let ((fun32 (intern (format nil "~S-MOD32" name)))
+ (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
+ (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
+ (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
+ (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
+ (vop32u (intern (format nil "FAST-~S-MOD32/UNSIGNED=>UNSIGNED" name)))
+ (vop32f (intern (format nil "FAST-~S-MOD32/FIXNUM=>FIXNUM" name)))
+ (vop32cu (intern (format nil "FAST-~S-MOD32-C/UNSIGNED=>UNSIGNED" name)))
+ (vop32cf (intern (format nil "FAST-~S-MOD32-C/FIXNUM=>FIXNUM" name)))
+ (sfun30 (intern (format nil "~S-SMOD30" name)))
+ (svop30f (intern (format nil "FAST-~S-SMOD30/FIXNUM=>FIXNUM" name)))
+ (svop30cf (intern (format nil "FAST-~S-SMOD30-C/FIXNUM=>FIXNUM" name))))
+ `(progn
+ (define-modular-fun ,fun32 (x y) ,name :unsigned 32)
+ (define-modular-fun ,sfun30 (x y) ,name :signed 30)
+ (define-vop (,vop32u ,vopu) (:translate ,fun32))
+ (define-vop (,vop32f ,vopf) (:translate ,fun32))
+ (define-vop (,svop30f ,vopf) (:translate ,sfun30))
+ ,@(when -c-p
+ `((define-vop (,vop32cu ,vopcu) (:translate ,fun32))
+ (define-vop (,svop30cf ,vopcf) (:translate ,sfun30))))))))
+ (def + t)
+ (def - t)
+ ;; (no -C variant as x86 MUL instruction doesn't take an immediate)
+ (def * nil))
+
(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
(sb!c::give-up-ir1-transform))
'(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
+(define-vop (fast-ash-left-smod30-c/fixnum=>fixnum
+ fast-ash-c/fixnum=>fixnum)
+ (:translate ash-left-smod30))
+
+(define-vop (fast-ash-left-smod30/fixnum=>fixnum
+ fast-ash-left/fixnum=>fixnum))
+(deftransform ash-left-smod30 ((integer count)
+ ((signed-byte 30) (unsigned-byte 5)))
+ (when (sb!c::constant-lvar-p count)
+ (sb!c::give-up-ir1-transform))
+ '(%primitive fast-ash-left-smod30/fixnum=>fixnum integer count))
+
(in-package "SB!C")
(defknown sb!vm::%lea-mod32 (integer integer (member 1 2 4 8) (signed-byte 32))
(unsigned-byte 32)
(foldable flushable movable))
+(defknown sb!vm::%lea-smod30 (integer integer (member 1 2 4 8) (signed-byte 32))
+ (signed-byte 30)
+ (foldable flushable movable))
-(define-modular-fun-optimizer %lea ((base index scale disp) :width width)
+(define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
(when (and (<= width 32)
(constant-lvar-p scale)
(constant-lvar-p disp))
- (cut-to-width base width)
- (cut-to-width index width)
+ (cut-to-width base :unsigned width)
+ (cut-to-width index :unsigned width)
'sb!vm::%lea-mod32))
+(define-modular-fun-optimizer %lea ((base index scale disp) :signed :width width)
+ (when (and (<= width 30)
+ (constant-lvar-p scale)
+ (constant-lvar-p disp))
+ (cut-to-width base :signed width)
+ (cut-to-width index :signed width)
+ 'sb!vm::%lea-smod30))
#+sb-xc-host
-(defun sb!vm::%lea-mod32 (base index scale disp)
- (ldb (byte 32 0) (%lea base index scale disp)))
+(progn
+ (defun sb!vm::%lea-mod32 (base index scale disp)
+ (ldb (byte 32 0) (%lea base index scale disp)))
+ (defun sb!vm::%lea-smod30 (base index scale disp)
+ (mask-signed-field 30 (%lea base index scale disp))))
#-sb-xc-host
-(defun sb!vm::%lea-mod32 (base index scale disp)
- (let ((base (logand base #xffffffff))
- (index (logand index #xffffffff)))
- ;; can't use modular version of %LEA, as we only have VOPs for
- ;; constant SCALE and DISP.
- (ldb (byte 32 0) (+ base (* index scale) disp))))
+(progn
+ (defun sb!vm::%lea-mod32 (base index scale disp)
+ (let ((base (logand base #xffffffff))
+ (index (logand index #xffffffff)))
+ ;; can't use modular version of %LEA, as we only have VOPs for
+ ;; constant SCALE and DISP.
+ (ldb (byte 32 0) (+ base (* index scale) disp))))
+ (defun sb!vm::%lea-smod30 (base index scale disp)
+ (let ((base (mask-signed-field 30 base))
+ (index (mask-signed-field 30 index)))
+ ;; can't use modular version of %LEA, as we only have VOPs for
+ ;; constant SCALE and DISP.
+ (mask-signed-field 30 (+ base (* index scale) disp)))))
(in-package "SB!VM")
(define-vop (%lea-mod32/unsigned=>unsigned
%lea/unsigned=>unsigned)
(:translate %lea-mod32))
+(define-vop (%lea-smod30/fixnum=>fixnum
+ %lea/fixnum=>fixnum)
+ (:translate %lea-smod30))
;;; logical operations
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
(define-vop (lognot-mod32/unsigned=>unsigned)
(:translate lognot-mod32)
(:args (x :scs (unsigned-reg unsigned-stack) :target r
(move r x)
(inst not r)))
-(define-modular-fun logxor-mod32 (x y) logxor 32)
+(define-modular-fun logxor-mod32 (x y) logxor :unsigned 32)
(define-vop (fast-logxor-mod32/unsigned=>unsigned
fast-logxor/unsigned=>unsigned)
(:translate logxor-mod32))
(define-vop (fast-logxor-mod32-c/unsigned=>unsigned
fast-logxor-c/unsigned=>unsigned)
(:translate logxor-mod32))
+(define-vop (fast-logxor-mod32/fixnum=>fixnum
+ fast-logxor/fixnum=>fixnum)
+ (:translate logxor-mod32))
+(define-vop (fast-logxor-mod32-c/fixnum=>fixnum
+ fast-logxor-c/fixnum=>fixnum)
+ (:translate logxor-mod32))
(define-source-transform logeqv (&rest args)
(if (oddp (length args))
(in-package "SB!C")
+(defun mask-result (class width result)
+ (ecase class
+ (:unsigned
+ `(logand ,result ,(1- (ash 1 width))))
+ (:signed
+ `(mask-signed-field ,width ,result))))
+
;;; 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)
+(defun basic-decompose-multiplication (class width 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))))
+ (mask-result class width
+ `(%lea ,arg
+ ,(decompose-multiplication class width
+ 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))))
+ (mask-result class width
+ `(%lea ,(decompose-multiplication class width
+ 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))))))
+ (mask-result class width
+ `(ash ,(decompose-multiplication class width
+ arg (ash num (- r0)) n-bits condensed)
+ ,r0))))))
-(defun decompose-multiplication (arg num n-bits condensed)
+(defun decompose-multiplication (class width arg num n-bits condensed)
(cond
((= n-bits 0) 0)
((= num 1) arg)
((= n-bits 1)
- `(logand #xffffffff (ash ,arg ,(1- (integer-length num)))))
+ (mask-result class width `(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))
(let ((n2 (+ (ash 1 (1+ j))
(ash (ldb (byte (- 32 (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))))))))
+ (mask-result class width
+ `(- ,(optimize-multiply class width arg n2)
+ ,(optimize-multiply class width 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)
+ (return `(let ((,x ,(optimize-multiply class width arg (/ num i))))
+ ,(mask-result class width
+ `(%lea ,x ,x (1- ,i) 0)))))))))
+ (t (basic-decompose-multiplication class width arg num n-bits condensed))))
+
+(defun optimize-multiply (class width arg x)
(let* ((n-bits (logcount x))
(condensed (make-array n-bits)))
(let ((count 0) (bit 0))
(setf count 1)
(incf bit))
(t (incf count)))))
- (decompose-multiplication arg x n-bits condensed)))
+ (decompose-multiplication class width arg x n-bits condensed)))
-(defun *-transformer (y)
+(defun *-transformer (class width y)
(cond
((= y (ash 1 (integer-length y)))
;; there's a generic transform for y = 2^k
;; FIXME: should make this more fine-grained. If nothing else,
;; there should probably be a cutoff of about 9 instructions on
;; pentium-class machines.
- (t (optimize-multiply 'x y))))
+ (t (optimize-multiply class width 'x y))))
(deftransform * ((x y)
((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
(unsigned-byte 32))
"recode as leas, shifts and adds"
(let ((y (lvar-value y)))
- (*-transformer y)))
-
+ (*-transformer :unsigned 32 y)))
(deftransform sb!vm::*-mod32
((x y) ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
(unsigned-byte 32))
"recode as leas, shifts and adds"
(let ((y (lvar-value y)))
- (*-transformer y)))
+ (*-transformer :unsigned 32 y)))
+
+(deftransform * ((x y)
+ ((signed-byte 30) (constant-arg (unsigned-byte 32)))
+ (signed-byte 30))
+ "recode as leas, shifts and adds"
+ (let ((y (lvar-value y)))
+ (*-transformer :signed 30 y)))
+(deftransform sb!vm::*-smod30
+ ((x y) ((signed-byte 30) (constant-arg (unsigned-byte 32)))
+ (signed-byte 30))
+ "recode as leas, shifts and adds"
+ (let ((y (lvar-value y)))
+ (*-transformer :signed 30 y)))
;;; FIXME: we should also be able to write an optimizer or two to
;;; convert (+ (* x 2) 17), (- (* x 9) 5) to a %LEA.
(dotimes (i 100)
(when (> (funcall fun t) 9)
(error "bad RANDOM event"))))
+
+;;; 0.8.17.28-sma.1 lost derived type information.
+(handler-bind ((sb-ext:compiler-note #'error))
+ (compile nil
+ '(lambda (x y v)
+ (declare (optimize (speed 3) (safety 0)))
+ (declare (type (integer 0 80) x)
+ (type (integer 0 11) y)
+ (type (simple-array (unsigned-byte 32) (*)) v))
+ (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y))
+ nil)))
;;; 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.17.28"
+"0.8.17.29"
projects / sbcl.git / commitdiff