"DEF-IR1-TRANSLATOR"
"!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS"
"DEFINE-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE"
- "DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUN"
+ "DEFINE-ASSEMBLY-ROUTINE"
+ "DEFINE-MODULAR-FUN"
+ "DEFINE-MOVE-FUN"
"DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE"
"DEFINE-STORAGE-CLASS" "DEFINE-VOP"
"DEFKNOWN" "DEFOPTIMIZER"
(def minusp "Is this real number strictly negative?")
(def oddp "Is this integer odd?")
(def evenp "Is this integer even?"))
+\f
+;;;; modular functions
+#.
+(collect ((forms))
+ (flet ((definition (name width pattern)
+ ;; We rely on (SUBTYPEP `(UNSIGNED-BYTE ,WIDTH)
+ ;; 'BIGNUM-ELEMENT-TYPE)
+ `(defun ,name (x y)
+ (flet ((prepare-argument (x)
+ (declare (integer x))
+ (etypecase x
+ ((unsigned-byte ,width) x)
+ (bignum-element-type (logand x ,pattern))
+ (fixnum (logand x ,pattern))
+ (bignum (logand (%bignum-ref x 0) ,pattern)))))
+ (,name (prepare-argument x) (prepare-argument y))))))
+ (loop for info being each hash-value of sb!c::*modular-funs*
+ ;; FIXME: We need to process only "toplevel" functions
+ do (loop for (width . name) in info
+ for pattern = (1- (ash 1 width))
+ do (forms (definition name width pattern)))))
+ `(progn ,@(forms)))
;;; the maximum number of SCs in any implementation
(def!constant sc-number-limit 32)
+\f
+;;; Modular functions
+
+;;; hash: name -> ({(width . fun)}*)
+(defvar *modular-funs*
+ (make-hash-table :test 'eq))
+
+;;; List of increasing widths
+(defvar *modular-funs-widths* nil)
+
+(defun find-modular-version (fun-name width)
+ (let ((info (gethash fun-name *modular-funs*)))
+ (cdr (find-if (lambda (item-width) (>= item-width width))
+ info
+ :key #'car))))
+
+(defun %define-modular-fun (name prototype width)
+ (let* ((list (gethash prototype *modular-funs*))
+ (entry (assoc width list)))
+ (if entry
+ (unless (eq name (cdr entry))
+ (setf (cdr entry) name)
+ (style-warn "Redefining modular version ~S of ~S for width ~S."
+ name prototype width))
+ (setf (gethash prototype *modular-funs*)
+ (merge 'list (list (cons width name)) list #'<))))
+ (setq *modular-funs-widths*
+ (merge 'list (list width) *modular-funs-widths* #'<)))
+
+(defmacro define-modular-fun (name prototype width)
+ (check-type name symbol)
+ (check-type prototype symbol)
+ (check-type width unsigned-byte)
+ `(progn
+ (%define-modular-fun ',name ',prototype ,width)
+ (defknown ,name (integer integer) (unsigned-byte ,width)
+ (foldable flushable movable))
+ ))
(logior (logand new mask)
(logand int (lognot mask)))))
\f
+;;; modular functions
+
+;;; Try to cut all uses of the continuation CONT to WIDTH bits.
+(defun cut-to-width (cont width)
+ (declare (type continuation cont) (type (integer 0) width))
+ (labels ((cut-node (node)
+ (when (and (combination-p node)
+ (fun-info-p (basic-combination-kind node)))
+ (let* ((fun-ref (continuation-use (combination-fun node)))
+ (fun-name (leaf-source-name (ref-leaf fun-ref)))
+ (modular-fun-name (find-modular-version fun-name width)))
+ (when modular-fun-name
+ (change-ref-leaf fun-ref
+ (find-free-fun modular-fun-name
+ "in a strange place"))
+ (setf (combination-kind node) :full)
+ (setf (node-derived-type node)
+ (values-specifier-type `(values (unsigned-byte ,width)
+ &optional)))
+ (setf (continuation-%derived-type (node-cont node)) nil)
+ (setf (node-reoptimize node) t)
+ (setf (block-reoptimize (node-block node)) t)
+ (setf (component-reoptimize (node-component node)) t)
+ (dolist (arg (basic-combination-args node))
+ (cut-continuation arg))))))
+ (cut-continuation (cont)
+ (do-uses (node cont)
+ (cut-node node))))
+ (cut-continuation cont)))
+
+(defoptimizer (logand optimizer) ((x y) 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)
+ (>= low 0))
+ (let ((width (integer-length high)))
+ (when (some (lambda (x) (<= width x))
+ *modular-funs-widths*)
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
+ (cut-to-width x width)
+ (cut-to-width y width)
+ nil ; After fixing above, replace with T.
+ )))))))
+\f
;;; miscellanous numeric transforms
;;; If a constant appears as the first arg, swap the args.
(def logxor -1 (lognot x))
(def logxor 0 x))
+(deftransform logand ((x y) (* (constant-arg t)) *)
+ "fold identity operation"
+ (let ((y (continuation-value y)))
+ (unless (and (plusp y)
+ (= y (1- (ash 1 (integer-length y)))))
+ (give-up-ir1-transform))
+ (unless (csubtypep (continuation-type x)
+ (specifier-type `(integer 0 ,y)))
+ (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) *)
(inst mov tmp y)
(inst shr tmp 18)
(inst xor y tmp)))
+\f
+;;; Modular functions
+(define-modular-fun +-mod32 + 32)
+
+(define-vop (fast-+-mod32/unsigned=>unsigned fast-safe-arith-op)
+ (:translate +-mod32)
+ (:args (x :scs (unsigned-reg) :target r
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (r :scs (unsigned-reg) :from (:argument 0)
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (location= x r)))))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:generator 5
+ (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg) (sc-is r unsigned-reg)
+ (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r 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.2.24"
+"0.8.2.25"
projects / sbcl.git / commitdiff