X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=4da5db16a02d8d3ae4f314500785bda4bc8030db;hb=1e9966d5f24709d227e20911b4e1ddd27c87a00e;hp=fe7f950a83785e3aae7953c280ccf18d2f32de46;hpb=80d37651bc4cba800bbf2ba38ea720d734fbae4a;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index fe7f950..4da5db1 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2518,8 +2518,12 @@
 ;;; "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.
+;;; 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 width)
   (declare (type lvar lvar) (type (integer 0) width))
   (labels ((reoptimize-node (node name)
@@ -2536,26 +2540,32 @@
                         (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))))
+                      (modular-fun (find-modular-version fun-name width)))
                  (when (and modular-fun
-                            (not (and (eq name 'logand)
+                            (not (and (eq fun-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
+                   (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))
-                   (dolist (arg (basic-combination-args node))
-                     (when (cut-lvar arg)
-                       (setq did-something t)))
-                   (when did-something
-                     (reoptimize-node node fun-name))
-                   did-something))))
+                     (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)