From: Nikodemus Siivola Date: Sat, 12 Feb 2011 15:42:48 +0000 (+0000) Subject: 1.0.45.25: better constant folding in arithmetic functions X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8466309b55b6d28e0b850384362d255b969fceef;p=sbcl.git 1.0.45.25: better constant folding in arithmetic functions Patch by Heka Deep, lp#676414, edited to retain identities and added a random-tester. * Folds constants in expressions such as (+ 3 a 5 b 7 c). * Constants are collected by calling the `reduce-constants' function from the `source-transform-transitive' and `source-transform-intransitive' functions. Constants adding up to identities are retained so that SNaNs don't sneak past. --- diff --git a/NEWS b/NEWS index 6679277..738319c 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,8 @@ changes relative to sbcl-1.0.45: with applicable non-standard (SETF SLOT-VALUE-USING-CLASS), SLOT-BOUNDP-USING-CLASS, and INITIALIZE-INSTANCE :AROUND methods, speeding up instance creation in those cases. + * optimization: arithmetic operations with multiple constant arguments in now + have them reduced at compile-time. (lp#676414) * bug fix: local tail calls to DYNAMIC-EXTENT functions can no longer cause lifetime analysis to overwrite closed-over variables (lp#681092). * bug fix: encoding errors from some multibyte external formats such as EUC-JP diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index ed2f97b..b570192 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3754,34 +3754,57 @@ ;;;; versions, and degenerate cases are flushed. ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION. -(declaim (ftype (function (symbol t list) list) associate-args)) -(defun associate-args (function first-arg more-args) +(declaim (ftype (sfunction (symbol t list t) list) associate-args)) +(defun associate-args (fun first-arg more-args identity) (let ((next (rest more-args)) (arg (first more-args))) (if (null next) - `(,function ,first-arg ,arg) - (associate-args function `(,function ,first-arg ,arg) next)))) + `(,fun ,first-arg ,(if arg arg identity)) + (associate-args fun `(,fun ,first-arg ,arg) next identity)))) + +;;; Reduce constants in ARGS list. +(declaim (ftype (sfunction (symbol list t symbol) list) reduce-constants)) +(defun reduce-constants (fun args identity one-arg-result-type) + (let ((one-arg-constant-p (ecase one-arg-result-type + (number #'numberp) + (integer #'integerp))) + (reduced-value identity) + (reduced-p nil)) + (collect ((not-constants)) + (dolist (arg args) + (if (funcall one-arg-constant-p arg) + (setf reduced-value (funcall fun reduced-value arg) + reduced-p t) + (not-constants arg))) + ;; It is tempting to drop constants reduced to identity here, + ;; but if X is SNaN in (* X 1), we cannot drop the 1. + (if (not-constants) + (if reduced-p + `(,reduced-value ,@(not-constants)) + (not-constants)) + `(,reduced-value))))) ;;; Do source transformations for transitive functions such as +. ;;; One-arg cases are replaced with the arg and zero arg cases with -;;; the identity. ONE-ARG-RESULT-TYPE is, if non-NIL, the type to -;;; ensure (with THE) that the argument in one-argument calls is. +;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE) +;;; that the argument in one-argument calls is. +(declaim (ftype (function (symbol list t &optional symbol list) + (values t &optional (member nil t))) + source-transform-transitive)) (defun source-transform-transitive (fun args identity - &optional one-arg-result-type) - (declare (symbol fun) (list args)) + &optional (one-arg-result-type 'number) + (one-arg-prefixes '(values))) (case (length args) (0 identity) - (1 (if one-arg-result-type - `(values (the ,one-arg-result-type ,(first args))) - `(values ,(first args)))) + (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args)))) (2 (values nil t)) - (t - (associate-args fun (first args) (rest args))))) + (t (let ((reduced-args (reduce-constants fun args identity one-arg-result-type))) + (associate-args fun (first reduced-args) (rest reduced-args) identity))))) (define-source-transform + (&rest args) - (source-transform-transitive '+ args 0 'number)) + (source-transform-transitive '+ args 0)) (define-source-transform * (&rest args) - (source-transform-transitive '* args 1 'number)) + (source-transform-transitive '* args 1)) (define-source-transform logior (&rest args) (source-transform-transitive 'logior args 0 'integer)) (define-source-transform logxor (&rest args) @@ -3790,41 +3813,30 @@ (source-transform-transitive 'logand args -1 'integer)) (define-source-transform logeqv (&rest args) (source-transform-transitive 'logeqv args -1 'integer)) - -;;; Note: we can't use SOURCE-TRANSFORM-TRANSITIVE for GCD and LCM -;;; because when they are given one argument, they return its absolute -;;; value. - (define-source-transform gcd (&rest args) - (case (length args) - (0 0) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-args 'gcd (first args) (rest args))))) - + (source-transform-transitive 'gcd args 0 'integer '(abs))) (define-source-transform lcm (&rest args) - (case (length args) - (0 1) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-args 'lcm (first args) (rest args))))) + (source-transform-transitive 'lcm args 1 'integer '(abs))) ;;; Do source transformations for intransitive n-arg functions such as ;;; /. With one arg, we form the inverse. With two args we pass. ;;; Otherwise we associate into two-arg calls. -(declaim (ftype (function (symbol list t) +(declaim (ftype (function (symbol symbol list t list &optional symbol) (values list &optional (member nil t))) source-transform-intransitive)) -(defun source-transform-intransitive (function args inverse) +(defun source-transform-intransitive (fun fun* args identity one-arg-prefixes + &optional (one-arg-result-type 'number)) (case (length args) ((0 2) (values nil t)) - (1 `(,@inverse ,(first args))) - (t (associate-args function (first args) (rest args))))) + (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args)))) + (t (let ((reduced-args + (reduce-constants fun* (rest args) identity one-arg-result-type))) + (associate-args fun (first args) reduced-args identity))))) (define-source-transform - (&rest args) - (source-transform-intransitive '- args '(%negate))) + (source-transform-intransitive '- '+ args 0 '(%negate))) (define-source-transform / (&rest args) - (source-transform-intransitive '/ args '(/ 1))) + (source-transform-intransitive '/ '* args 1 '(/ 1))) ;;;; transforming APPLY diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp index 746b88b..5a6ca2f 100644 --- a/tests/arith.pure.lisp +++ b/tests/arith.pure.lisp @@ -372,3 +372,35 @@ (assert (raises-error? (expt 0.0 0.0) sb-int:arguments-out-of-domain-error)) (assert (raises-error? (expt 0 0.0) sb-int:arguments-out-of-domain-error)) (assert (eql (expt 0.0 0) 1.0))) + +(with-test (:name :multiple-constant-folding) + (let ((*random-state* (make-random-state t))) + (flet ((make-args () + (let (args vars) + (loop repeat (1+ (random 12)) + do (if (zerop (random 2)) + (let ((var (gensym))) + (push var args) + (push var vars)) + (push (- (random 21) 10) args))) + (values args vars)))) + (dolist (op '(+ * logior logxor logand logeqv gcd lcm - /)) + (loop repeat 10 + do (multiple-value-bind (args vars) (make-args) + (let ((fast (compile nil `(lambda ,vars + (,op ,@args)))) + (slow (compile nil `(lambda ,vars + (declare (notinline ,op)) + (,op ,@args))))) + (loop repeat 3 + do (let* ((call-args (loop repeat (length vars) + collect (- (random 21) 10))) + (fast-result (handler-case + (apply fast call-args) + (division-by-zero () :div0))) + (slow-result (handler-case + (apply fast call-args) + (division-by-zero () :div0)))) + (if (eql fast-result slow-result) + (print (list :ok `(,op ,@args) :=> fast-result)) + (error "oops: ~S, ~S" args call-args))))))))))) diff --git a/version.lisp-expr b/version.lisp-expr index f2d9ca2..182bfd6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.45.24" +"1.0.45.25"