- (cut-node (node &aux did-something)
- (when (and (not (block-delete-p (node-block node)))
- (ref-p node)
- (constant-p (ref-leaf node)))
- (let* ((constant-value (constant-value (ref-leaf node)))
- (new-value (if signedp
- (mask-signed-field width constant-value)
- (ldb (byte width 0) constant-value))))
- (unless (= constant-value new-value)
- (change-ref-leaf node (make-constant new-value))
- (let ((lvar (node-lvar node)))
- (setf (lvar-%derived-type lvar)
- (and (lvar-has-single-use-p lvar)
- (make-values-type :required (list (ctype-of new-value))))))
- (setf (block-reoptimize (node-block node)) t)
- (reoptimize-component (node-component node) :maybe)
- (return-from cut-node t))))
- (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 kind signedp 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))
+ (insert-lvar-cut (lvar)
+ "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
+ to the required bit width. Returns T if any change was made.
+
+ When the destination of LVAR will definitely cut LVAR's value
+ to width (i.e. it's a logand or mask-signed-field with constant
+ other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
+ (binding* ((dest (lvar-dest lvar) :exit-if-null)
+ (nil (combination-p dest) :exit-if-null)
+ (name (lvar-fun-name (combination-fun dest) t))
+ (args (combination-args dest)))
+ (case name
+ (logand
+ (when (= 2 (length args))
+ (let ((other (if (eql (first args) lvar)
+ (second args)
+ (first args))))
+ (when (and (constant-lvar-p other)
+ (ctypep (lvar-value other) type)
+ (not signedp))
+ (return-from insert-lvar-cut)))))
+ (mask-signed-field
+ (when (and signedp
+ (eql lvar (second args))
+ (constant-lvar-p (first args))
+ (<= (lvar-value (first args)) width))
+ (return-from insert-lvar-cut)))))
+ (filter-lvar lvar
+ (if signedp
+ `(mask-signed-field ,width 'dummy)
+ `(logand 'dummy ,(ldb (byte width 0) -1))))
+ (do-uses (node lvar)
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe))
+ t)
+ (cut-node (node &aux did-something over-wide)
+ "Try to cut a node to width. The primary return value is
+ whether we managed to cut (cleverly), and the second whether
+ anything was changed. The third return value tells whether
+ the cut value might be wider than expected."
+ (when (block-delete-p (node-block node))
+ (return-from cut-node (values t nil)))
+ (typecase node
+ (ref
+ (typecase (ref-leaf node)
+ (constant
+ (let* ((constant-value (constant-value (ref-leaf node)))
+ (new-value (if signedp
+ (mask-signed-field width constant-value)
+ (ldb (byte width 0) constant-value))))
+ (cond ((= constant-value new-value)
+ (values t nil)) ; we knew what to do and did nothing
+ (t
+ (change-ref-leaf node (make-constant new-value)
+ :recklessly t)
+ (let ((lvar (node-lvar node)))
+ (setf (lvar-%derived-type lvar)
+ (and (lvar-has-single-use-p lvar)
+ (make-values-type :required (list (ctype-of new-value))))))
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe)
+ (values t t)))))))
+ (combination
+ (when (eq (basic-combination-kind node) :known)
+ (let* ((fun-ref (lvar-use (combination-fun node)))
+ (fun-name (lvar-fun-name (combination-fun node)))
+ (modular-fun (find-modular-version fun-name kind
+ signedp width)))
+ (cond ((not modular-fun)
+ ;; don't know what to do here
+ (values nil nil))
+ ((let ((dtype (single-value-type
+ (node-derived-type node))))
+ (and
+ (case fun-name
+ (logand
+ (csubtypep dtype
+ (specifier-type 'unsigned-byte)))
+ (logior
+ (csubtypep dtype
+ (specifier-type '(integer * 0))))
+ (mask-signed-field
+ t)
+ (t nil))
+ (csubtypep dtype type)))
+ ;; nothing to do
+ (values t nil))
+ (t
+ (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))