`(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)
- (setf (component-reoptimize (node-component node)) t))
- (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) *)
projects / sbcl.git / blobdiff