- (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)
- (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))))))
- (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))))