-;;; -- lower N bits of a result depend only on lower N bits of
-;;; arguments.
-
-;;; Try to recursively 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 (find-modular-version fun-name width))
- (name (and modular-fun
- (modular-fun-info-name modular-fun))))
- (when modular-fun
- (change-ref-leaf fun-ref
- (find-free-fun name "in a strange place"))
- (setf (combination-kind node) :full)
- (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)
- (dolist (arg (basic-combination-args node))
- (cut-continuation arg))))))
- (cut-continuation (cont)
- (do-uses (node cont)
- (cut-node node))))
- (cut-continuation cont)))
+;;; and similar for other arguments.
+
+(defun make-modular-fun-type-deriver (prototype kind width signedp)
+ (declare (ignore kind))
+ #!-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 signedp
+ ((nil) (let ((mask (1- (ash 1 width))))
+ `(integer ,mask ,mask)))
+ ((t) `(signed-byte ,width))))))
+ (lambda (call)
+ (let ((res (funcall fun call)))
+ (when res
+ (if (eq signedp nil)
+ (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 signedp
+ ((nil) (let ((mask (1- (ash 1 width))))
+ `(integer ,mask ,mask)))
+ ((t) `(signed-byte ,width))))))
+ (if (eq signedp nil)
+ (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
+;;; "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. For most functions (e.g. for +) we cut all arguments; for
+;;; others (e.g. for ASH) we have "optimizers", cutting only necessary
+;;; arguments (maybe to a different width) and returning the name of a
+;;; 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 kind width signedp)
+ (declare (type lvar lvar) (type (integer 0) width))
+ (let ((type (specifier-type (if (zerop width)
+ '(eql 0)
+ `(,(ecase signedp
+ ((nil) 'unsigned-byte)
+ ((t) '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 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))
+ (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))))
+
+(defun best-modular-version (width signedp)
+ ;; 1. exact width-matched :untagged
+ ;; 2. >/>= width-matched :tagged
+ ;; 3. >/>= width-matched :untagged
+ (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
+ (uswidths (modular-class-widths *untagged-signed-modular-class*))
+ (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
+ (twidths (modular-class-widths *tagged-modular-class*)))
+ (let ((exact (find (cons width signedp) uwidths :test #'equal)))
+ (when exact
+ (return-from best-modular-version (values width :untagged signedp))))
+ (flet ((inexact-match (w)
+ (cond
+ ((eq signedp (cdr w)) (<= width (car w)))
+ ((eq signedp nil) (< width (car w))))))
+ (let ((tgt (find-if #'inexact-match twidths)))
+ (when tgt
+ (return-from best-modular-version
+ (values (car tgt) :tagged (cdr tgt)))))
+ (let ((ugt (find-if #'inexact-match uwidths)))
+ (when ugt
+ (return-from best-modular-version
+ (values (car ugt) :untagged (cdr ugt))))))))