From ead48ef96b8954b7f3d85b1b38988e6ec3b2a37f Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Sun, 2 Feb 1992 22:43:56 +0000 Subject: [PATCH] Changed COMMUTATIVE-ARG-SWAP to actually splice in the constant arg, so that variable substitution can't swap it back again. Fixed multiple recoding to include many TRULY-THE's in the expansion so that the resulting shift-and-add code would actually open coded. Added comprehensive handling of arithmetic and logical identities when an arg is -1, 0 or +1. Fixed the (- 0 x) ==> (%negate x) transform to be inhibited when the 0 is more contagious than X, or is -0.0. --- compiler/srctran.lisp | 137 +++++++++++++++++++++++++++++++++--------- 1 file changed, 108 insertions(+), 29 deletions(-) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index d336644ee..001b56337 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.32 1991/11/14 05:51:04 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.33 1992/02/02 22:43:56 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -882,12 +882,14 @@ (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node) (if (and (constant-continuation-p x) (not (constant-continuation-p y))) - `(,(continuation-function-name (basic-combination-fun node)) y x) + `(,(continuation-function-name (basic-combination-fun node)) + y + ,(continuation-value x)) (give-up))) (dolist (x '(= char= + * logior logand logxor)) - (%deftransform x '(function * *) #'commutative-arg-swap)) - + (%deftransform x '(function * *) #'commutative-arg-swap + "place constant arg last.")) ;;; Handle the case of a constant boole-code. ;;; @@ -916,6 +918,8 @@ (t (abort-transform "~S illegal control arg to BOOLE." control))))) + +;;;; Convert multiply/divide to shifts. ;;; If arg is a constant power of two, turn * into a shift. ;;; @@ -943,35 +947,39 @@ (deftransform * ((x y) ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)) + "recode as shift and add" (unless (constant-continuation-p y) (give-up)) (let ((y (continuation-value y)) (result nil) (first-one nil)) - (flet ((add (next-factor) - (setf result - (if result - `(+ ,next-factor ,result) - next-factor)))) + (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x)) + (add (next-factor) + (setf result + (tub32 + (if result + `(+ ,(tub32 next-factor) + ,result) + next-factor))))) (declare (inline add)) (dotimes (bitpos 32) (if first-one - (when (not (logbitp bitpos y)) - (add (if (= (1+ first-one) bitpos) - ;; There is only a single bit in the string. - `(ash x ,first-one) - ;; There are at least two. - `(- (ash x ,bitpos) - (ash x ,first-one)))) - (setf first-one nil)) - (when (logbitp bitpos y) - (setf first-one bitpos)))) + (when (not (logbitp bitpos y)) + (add (if (= (1+ first-one) bitpos) + ;; There is only a single bit in the string. + `(ash x ,first-one) + ;; There are at least two. + `(- ,(tub32 `(ash x ,bitpos)) + ,(tub32 `(ash x ,first-one))))) + (setf first-one nil)) + (when (logbitp bitpos y) + (setf first-one bitpos)))) (when first-one (cond ((= first-one 31)) ((= first-one 30) (add '(ash x 30))) (t - (add `(- (ash x 31) (ash x ,first-one))))) + (add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one)))))) (add '(ash x 31)))) (or result 0))) @@ -1050,12 +1058,87 @@ (- (logand (- x) ,mask)) (logand x ,mask))))) - + +;;;; Arithmetic and logical identity operation elimination: +;;; ;;; Flush calls to random arith functions that convert to the identity -;;; function. -;;; -(deftransform ash ((x y) (* (constant-argument (member 0)))) - 'x) +;;; function or a constant. + + +(loop for (name identity result) in + '((ash 0 x) + (logand -1 x) + (logand 0 0) + (logior 0 x) + (logior -1 -1) + (logxor -1 (lognot x)) + (logxor 0 x)) do + (deftransform name ((x y) `(* (constant-argument (member ,identity))) '* + :eval-name t) + "fold identity operations" + result)) + + +;;; NOT-MORE-CONTAGIOUS -- Interface +;;; +;;; Return T if in an arithmetic op including continuations X and Y, the +;;; result type is not affected by the type of X. That is, Y is at least as +;;; contagious as X. +;;; +(defun not-more-contagious (x y) + (declare (type continuation x y)) + (let ((x (continuation-type x)) + (y (continuation-type y))) + (values (type= (numeric-contagion x y) + (numeric-contagion y y))))) + + +;;; OK-ZERO-OR-LOSE -- Interface +;;; +;;; If y is not constant, not zerop, or is -0.0, or is contagious, then give +;;; up. We throw out negative zero because it is likely to cause sign changes, +;;; and is not likely to appear in places where we actually case about +;;; optimizing identities. +;;; +(defun ok-zero-or-lose (x y) + (unless (constant-continuation-p y) (give-up)) + (let ((val (continuation-value y))) + (unless (and (zerop val) + (not (and (floatp val) (minusp (float-sign val)))) + (not-more-contagious y x)) + (give-up)))) + +(deftransform - ((x y)) + "convert (- 0 x) to negate" + (ok-zero-or-lose y x) + '(%negate y)) + +;;; Fold (OP x 0). +;;; +(loop for (name result) in + '((* 0) + (+ x) + (- x) + (expt 1)) do + (deftransform name ((x y) '* '* :eval-name t) + "fold zero arg" + (ok-zero-or-lose x y) + result)) + +;;; Fold (OP x +/-1) +;;; +(loop for (name result minus-result) in + '((* x (%negate x)) + (/ x (%negate x)) + (expt x (/ 1 x))) do + (deftransform name ((x y) '* '* :eval-name t) + "fold identity operations" + (unless (constant-continuation-p y) (give-up)) + (let ((val (continuation-value y))) + (unless (and (= (abs val) 1) + (not-more-contagious y x)) + (give-up)) + (if (minusp val) minus-result result)))) ;;;; Character operations: @@ -1425,10 +1508,6 @@ (def-source-transform - (&rest args) (source-transform-intransitive '- args 0)) (def-source-transform / (&rest args) (source-transform-intransitive '/ args 1)) -(deftransform - ((x y)) - (unless (and (constant-continuation-p x) (zerop (continuation-value x))) - (give-up)) - '(%negate y)) ;;;; Apply: -- GitLab