[Sbcl-commits] master: Exploit associativity to fold more constants

[Paul K. <pk...@us...>]

The branch "master" has been updated in SBCL:
       via  0d8a5fab0a83b5d8b92870dba57dc7b3ebcc89b2 (commit)
      from  09c78105eabc6bf2b339f421d4ed1df4678003db (commit)

- Log -----------------------------------------------------------------
commit 0d8a5fab0a83b5d8b92870dba57dc7b3ebcc89b2
Author: Paul Khuong <pv...@pv...>
Date:   Mon May 20 11:36:21 2013 -0400

    Exploit associativity to fold more constants
    
     * Implement transforms for logand, logior, logxor and logtest to
       detect patterns like (f (f x k1) k2) => (f x (f k1 k2)).
    
     * Same for + and * of rational values.
    
     * Similar logic for mask-signed-field: we only need to keep the
       narrowest width.
---
 NEWS                      |    3 ++
 src/compiler/srctran.lisp |   54 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 57 insertions(+), 0 deletions(-)

diff --git a/NEWS b/NEWS
index 11a6507..17c2f2b 100644
--- a/NEWS
+++ b/NEWS
@@ -73,6 +73,9 @@ changes relative to sbcl-1.1.7:
     compilation now inline the INVOKE-WITH-SAVED-FP-AND-PC dance.
   * optimization: ROOM no longer conses so egregiously on non-x86oid
     systems.
+  * optimization: associative bitwise operations reassociate patterns like
+    (f (f x k1) k2) to expose (f x (f k1 k2)).  Same for + and * of
+    rational values.
 
 changes in sbcl-1.1.7 relative to sbcl-1.1.6:
   * enhancement: TRACE :PRINT-ALL handles multiple-valued forms.
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 63f1980..b7e8a29 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3265,6 +3265,60 @@
       (give-up-ir1-transform))
     'x))
 
+;;; Pick off easy association opportunities for constant folding.
+;;; More complicated stuff that also depends on commutativity
+;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
+;;; probably be handled with a more general tree-rewriting pass.
+(macrolet ((def (operator &key (type 'integer) (folded operator))
+             `(deftransform ,operator ((x z) (,type (constant-arg ,type)))
+                ,(format nil "associate ~A/~A of constants"
+                         operator folded)
+                (binding* ((node  (if (lvar-has-single-use-p x)
+                                      (lvar-use x)
+                                      (give-up-ir1-transform)))
+                           (nil (or (and (combination-p node)
+                                         (eq (lvar-fun-name
+                                              (combination-fun node))
+                                             ',folded))
+                                    (give-up-ir1-transform)))
+                           (y   (second (combination-args node)))
+                           (nil (or (constant-lvar-p y)
+                                    (give-up-ir1-transform)))
+                           (y   (lvar-value y)))
+                  (unless (typep y ',type)
+                    (give-up-ir1-transform))
+                  (splice-fun-args x ',folded 2)
+                  `(lambda (x y z)
+                     (declare (ignore y z))
+                     (,',operator x ',(,folded y (lvar-value z))))))))
+  (def logand)
+  (def logior)
+  (def logxor)
+  (def logtest :folded logand)
+  (def + :type rational)
+  (def * :type rational))
+
+(deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *))
+  "Fold mask-signed-field/mask-signed-field of constant width"
+  (binding* ((node  (if (lvar-has-single-use-p x)
+                        (lvar-use x)
+                        (give-up-ir1-transform)))
+             (nil (or (combination-p node)
+                      (give-up-ir1-transform)))
+             (nil (or (eq (lvar-fun-name (combination-fun node))
+                          'mask-signed-field)
+                      (give-up-ir1-transform)))
+             (x-width (first (combination-args node)))
+             (nil (or (constant-lvar-p x-width)
+                      (give-up-ir1-transform)))
+             (x-width (lvar-value x-width)))
+    (unless (typep x-width 'unsigned-byte)
+      (give-up-ir1-transform))
+    (splice-fun-args x 'mask-signed-field 2)
+    `(lambda (width x-width x)
+       (declare (ignore width x-width))
+       (mask-signed-field ,(min (lvar-value width) x-width) x))))
+
 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
 ;;; (* 0 -4.0) is -0.0.
 (deftransform - ((x y) ((constant-arg (member 0)) rational) *)

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL