+;;; Modular functions
+
+;;; (ldb (byte s 0) (foo x y ...)) =
+;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...))
+;;;
+;;; and similar for other arguments.
+
+;;; Try to recursively cut all uses of the continuation CONT to WIDTH
+;;; bits.
+;;;
+;;; For good functions, we just recursively cut arguments; their
+;;; "goodness" means that the result will not increase (in the
+;;; (unsigned-byte +infinity) sense). An ordinary modular function is
+;;; replaced with the version, cutting its result to WIDTH or more
+;;; bits. 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 (cont width)
+ (declare (type continuation cont) (type (integer 0) width))
+ (labels ((reoptimize-node (node name)
+ (setf (node-derived-type node)
+ (fun-type-returns
+ (info :function :type name)))
+ (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))
+ (cut-node (node &aux did-something)
+ (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 (find-modular-version fun-name width))
+ (name (and (modular-fun-info-p modular-fun)
+ (modular-fun-info-name modular-fun))))
+ (when (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-continuation arg)
+ (setq did-something t)))
+ (when did-something
+ (reoptimize-node node fun-name))
+ did-something))))
+ (cut-continuation (cont &aux did-something)
+ (do-uses (node cont)
+ (when (cut-node node)
+ (setq did-something t)))
+ did-something))
+ (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