X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=1fcfe78b96fab202cbc405c2a4c294d31b81b170;hb=f8893c7c658bf9d9e0757c63e47af2fdea810f04;hp=8df9c256f98d3c6558bb544d9931dd9dd03271c8;hpb=b61003dec6f5af2b03549439155676666186283e;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 8df9c25..1fcfe78 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,55 +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))))
-		 (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))))))
+                      (modular-fun (find-modular-version fun-name width)))
+                 (when (and modular-fun
+                            (not (and (eq fun-name 'logand)
+                                      (csubtypep
+                                       (single-value-type (node-derived-type node))
+                                       (specifier-type `(unsigned-byte ,width))))))
+                   (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)
@@ -2631,22 +2612,22 @@
     (give-up-ir1-transform "BOOLE code is not a constant."))
   (let ((control (lvar-value op)))
     (case control
-      (#.boole-clr 0)
-      (#.boole-set -1)
-      (#.boole-1 'x)
-      (#.boole-2 'y)
-      (#.boole-c1 '(lognot x))
-      (#.boole-c2 '(lognot y))
-      (#.boole-and '(logand x y))
-      (#.boole-ior '(logior x y))
-      (#.boole-xor '(logxor x y))
-      (#.boole-eqv '(logeqv x y))
-      (#.boole-nand '(lognand x y))
-      (#.boole-nor '(lognor x y))
-      (#.boole-andc1 '(logandc1 x y))
-      (#.boole-andc2 '(logandc2 x y))
-      (#.boole-orc1 '(logorc1 x y))
-      (#.boole-orc2 '(logorc2 x y))
+      (#.sb!xc:boole-clr 0)
+      (#.sb!xc:boole-set -1)
+      (#.sb!xc:boole-1 'x)
+      (#.sb!xc:boole-2 'y)
+      (#.sb!xc:boole-c1 '(lognot x))
+      (#.sb!xc:boole-c2 '(lognot y))
+      (#.sb!xc:boole-and '(logand x y))
+      (#.sb!xc:boole-ior '(logior x y))
+      (#.sb!xc:boole-xor '(logxor x y))
+      (#.sb!xc:boole-eqv '(logeqv x y))
+      (#.sb!xc:boole-nand '(lognand x y))
+      (#.sb!xc:boole-nor '(lognor x y))
+      (#.sb!xc:boole-andc1 '(logandc1 x y))
+      (#.sb!xc:boole-andc2 '(logandc2 x y))
+      (#.sb!xc:boole-orc1 '(logorc1 x y))
+      (#.sb!xc:boole-orc2 '(logorc2 x y))
       (t
        (abort-ir1-transform "~S is an illegal control arg to BOOLE."
 			    control)))))