From bc55c207d295e0b94ad63ff8f306dc5186a2d1df Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 11 May 1993 13:50:58 +0000 Subject: [PATCH] Update transforms to inhibit ones which pessimize byte code. --- compiler/array-tran.lisp | 41 ++++++++++------- compiler/float-tran.lisp | 60 +++++++++++++----------- compiler/seqtran.lisp | 12 ++--- compiler/srctran.lisp | 99 ++++++++++++++++++++-------------------- compiler/typetran.lisp | 33 ++++++++------ 5 files changed, 132 insertions(+), 113 deletions(-) diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp index 28ea744e4..409e596fb 100644 --- a/compiler/array-tran.lisp +++ b/compiler/array-tran.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/array-tran.lisp,v 1.14 1991/11/12 14:14:14 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.15 1993/05/11 13:49:57 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -157,16 +157,19 @@ ;;; Convert VECTOR into a make-array followed by setfs of all the elements. ;;; (def-source-transform vector (&rest elements) - (let ((len (length elements)) - (n -1)) - (once-only ((n-vec `(make-array ,len))) - `(progn - ,@(mapcar #'(lambda (el) - (once-only ((n-val el)) - `(locally (declare (optimize (safety 0))) - (setf (svref ,n-vec ,(incf n)) ,n-val)))) - elements) - ,n-vec)))) + (if *byte-compiling* + (values nil t) + (let ((len (length elements)) + (n -1)) + (once-only ((n-vec `(make-array ,len))) + `(progn + ,@(mapcar #'(lambda (el) + (once-only ((n-val el)) + `(locally (declare (optimize (safety 0))) + (setf (svref ,n-vec ,(incf n)) + ,n-val)))) + elements) + ,n-vec))))) ;;; MAKE-STRING -- source-transform. @@ -174,9 +177,11 @@ ;;; Just convert it into a make-array. ;;; (def-source-transform make-string (length &key (initial-element #\NULL)) - `(make-array (the index ,length) - :element-type 'base-char - :initial-element ,initial-element)) + (if *byte-compiling* + (values nil t) + `(make-array (the index ,length) + :element-type 'base-char + :initial-element ,initial-element))) (defconstant array-info '((base-char #\NULL 8 vm:simple-string-type) @@ -499,9 +504,13 @@ (macrolet ((frob (reffer setter type) `(progn (def-source-transform ,reffer (a &rest i) - `(aref (the ,',type ,a) ,@i)) + (if *byte-compiling* + (values nil t) + `(aref (the ,',type ,a) ,@i))) (def-source-transform ,setter (a &rest i) - `(%aset (the ,',type ,a) ,@i))))) + (if *byte-compiling* + (values nil t) + `(%aset (the ,',type ,a) ,@i)))))) (frob svref %svset simple-vector) (frob schar %scharset simple-string) (frob char %charset string) diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index adabfb366..d1a39e7cf 100644 --- a/compiler/float-tran.lisp +++ b/compiler/float-tran.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/float-tran.lisp,v 1.15 1993/05/07 16:03:05 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.16 1993/05/11 13:50:47 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -24,26 +24,30 @@ (defknown %single-float (real) single-float (movable foldable flushable)) (defknown %double-float (real) double-float (movable foldable flushable)) -(deftransform float ((n &optional f) (* &optional single-float)) +(deftransform float ((n &optional f) (* &optional single-float) * + :when :both) + '(%single-float n)) -(deftransform float ((n f) (* double-float)) +(deftransform float ((n f) (* double-float) * :when :both) '(%double-float n)) -(deftransform %single-float ((n) (single-float)) +(deftransform %single-float ((n) (single-float) * :when :both) 'n) -(deftransform %double-float ((n) (double-float)) +(deftransform %double-float ((n) (double-float) * :when :both) 'n) (deftransform coerce ((n type) (* (constant-argument - (member float short-float single-float)))) + (member float short-float single-float))) + * :when :both) '(%single-float n)) (deftransform coerce ((n type) (* (constant-argument - (member double-float long-float)))) + (member double-float long-float))) + * :when :both) '(%double-float n)) ;;; Not strictly float functions, but primarily useful on floats: @@ -63,7 +67,8 @@ ;;; (macrolet ((frob (fun type) `(deftransform random ((num &optional state) - (,type &optional *)) + (,type &optional *) * + :when :both) "use inline float operations" '(,fun num state)))) (frob %random-single-float single-float) @@ -100,16 +105,17 @@ (defun double-float-low-bits (x) (double-float-low-bits x)) (def-source-transform float-sign (float1 &optional (float2 nil f2-p)) - (let ((n-f1 (gensym))) - (if f2-p - `(* (float-sign ,float1) (abs ,float2)) - `(let ((,n-f1 ,float1)) - (declare (float ,n-f1)) - (if (minusp (if (typep ,n-f1 'single-float) - (single-float-bits ,n-f1) - (double-float-high-bits ,n-f1))) - (float -1 ,n-f1) - (float 1 ,n-f1)))))) + (cond (*byte-compiling* (values nil t)) + (f2-p `(* (float-sign ,float1) (abs ,float2))) + (t + (let ((n-f1 (gensym))) + `(let ((,n-f1 ,float1)) + (declare (float ,n-f1)) + (if (minusp (if (typep ,n-f1 'single-float) + (single-float-bits ,n-f1) + (double-float-high-bits ,n-f1))) + (float -1 ,n-f1) + (float 1 ,n-f1))))))) ;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, SCALE-FLOAT: @@ -169,22 +175,22 @@ (defknown scale-double-float (double-float fixnum) double-float (movable foldable flushable)) -(deftransform decode-float ((x) (single-float)) +(deftransform decode-float ((x) (single-float) * :when :both) '(decode-single-float x)) -(deftransform decode-float ((x) (double-float)) +(deftransform decode-float ((x) (double-float) * :when :both) '(decode-double-float x)) -(deftransform integer-decode-float ((x) (single-float)) +(deftransform integer-decode-float ((x) (single-float) * :when :both) '(integer-decode-single-float x)) -(deftransform integer-decode-float ((x) (double-float)) +(deftransform integer-decode-float ((x) (double-float) * :when :both) '(integer-decode-double-float x)) -(deftransform scale-float ((f ex) (single-float *)) +(deftransform scale-float ((f ex) (single-float *) * :when :both) '(scale-single-float f ex)) -(deftransform scale-float ((f ex) (double-float *)) +(deftransform scale-float ((f ex) (double-float *) * :when :both) '(scale-double-float f ex)) @@ -221,7 +227,7 @@ ;;; has a precise representation as a float (such as 0). ;;; (macrolet ((frob (op) - `(deftransform ,op ((x y) (float rational)) + `(deftransform ,op ((x y) (float rational) :when :both) (unless (constant-continuation-p y) (give-up "Can't open-code float to rational comparison.")) (let ((val (continuation-value y))) @@ -283,7 +289,7 @@ (destructuring-bind (name prim rtype) stuff (deftransform name ((x) '(single-float) rtype :eval-name t) `(coerce (,prim (coerce x 'double-float)) 'single-float)) - (deftransform name ((x) '(double-float) rtype :eval-name t) + (deftransform name ((x) '(double-float) rtype :eval-name t :when :both) `(,prim x)))) (dolist (stuff '((expt %pow t) @@ -293,7 +299,7 @@ `(coerce (,prim (coerce x 'double-float) (coerce y 'double-float)) 'single-float)) - (deftransform name ((x y) '(double-float) rtype :eval-name t) + (deftransform name ((x y) '(double-float) rtype :eval-name t :when :both) `(,prim x y)))) (deftransform log ((x y) (float float) float) diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp index bd1b9f7cb..60b8c73e2 100644 --- a/compiler/seqtran.lisp +++ b/compiler/seqtran.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/seqtran.lisp,v 1.16 1992/08/05 00:36:42 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.17 1993/05/11 13:50:50 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -72,20 +72,20 @@ (def-source-transform mapcon (function list &rest more-lists) (mapper-transform function (cons list more-lists) :nconc nil)) -(deftransform elt ((s i) ((simple-array * (*)) *)) +(deftransform elt ((s i) ((simple-array * (*)) *) * :when :both) '(aref s i)) -(deftransform elt ((s i) (list *)) +(deftransform elt ((s i) (list *) * :when :both) '(nth i s)) -(deftransform %setelt ((s i v) ((simple-array * (*)) * *)) +(deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both) '(%aset s i v)) (deftransform %setelt ((s i v) (list * *)) '(setf (car (nthcdr i s)) v)) -(deftransform member ((e l &key (test #'eql)) * * :node node) +(deftransform member ((e l &key (test #'eql)) * * :node node :when :both) (unless (constant-continuation-p l) (give-up)) (let ((val (continuation-value l))) @@ -421,7 +421,7 @@ (destructuring-bind (fun pred*) stuff (deftransform fun ((string1 string2 &key (start1 0) end1 (start2 0) end2) - '* '* :eval-name t) + '* '* :eval-name t :when :both) `(,pred* string1 string2 start1 end1 start2 end2)))) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index 164783a2c..455d6c584 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.40 1993/02/03 18:26:14 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.41 1993/05/11 13:50:52 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -62,7 +62,7 @@ ;;; FUNCALL, then do the &REST APPLY thing, and let MV optimization figure ;;; things out. ;;; -(deftransform complement ((fun) * * :node node) +(deftransform complement ((fun) * * :node node :when :both) "open code" (multiple-value-bind (min max) (function-type-nargs (continuation-type fun)) @@ -84,34 +84,27 @@ ;;; ;;; Translate CxxR into car/cdr combos. -(def-source-transform caar (x) `(car (car ,x))) -(def-source-transform cadr (x) `(car (cdr ,x))) -(def-source-transform cdar (x) `(cdr (car ,x))) -(def-source-transform cddr (x) `(cdr (cdr ,x))) -(def-source-transform caaar (x) `(car (car (car ,x)))) -(def-source-transform caadr (x) `(car (car (cdr ,x)))) -(def-source-transform cadar (x) `(car (cdr (car ,x)))) -(def-source-transform caddr (x) `(car (cdr (cdr ,x)))) -(def-source-transform cdaar (x) `(cdr (car (car ,x)))) -(def-source-transform cdadr (x) `(cdr (car (cdr ,x)))) -(def-source-transform cddar (x) `(cdr (cdr (car ,x)))) -(def-source-transform cdddr (x) `(cdr (cdr (cdr ,x)))) -(def-source-transform caaaar (x) `(car (car (car (car ,x))))) -(def-source-transform caaadr (x) `(car (car (car (cdr ,x))))) -(def-source-transform caadar (x) `(car (car (cdr (car ,x))))) -(def-source-transform caaddr (x) `(car (car (cdr (cdr ,x))))) -(def-source-transform cadaar (x) `(car (cdr (car (car ,x))))) -(def-source-transform cadadr (x) `(car (cdr (car (cdr ,x))))) -(def-source-transform caddar (x) `(car (cdr (cdr (car ,x))))) -(def-source-transform cadddr (x) `(car (cdr (cdr (cdr ,x))))) -(def-source-transform cdaaar (x) `(cdr (car (car (car ,x))))) -(def-source-transform cdaadr (x) `(cdr (car (car (cdr ,x))))) -(def-source-transform cdadar (x) `(cdr (car (cdr (car ,x))))) -(def-source-transform cdaddr (x) `(cdr (car (cdr (cdr ,x))))) -(def-source-transform cddaar (x) `(cdr (cdr (car (car ,x))))) -(def-source-transform cddadr (x) `(cdr (cdr (car (cdr ,x))))) -(def-source-transform cdddar (x) `(cdr (cdr (cdr (car ,x))))) -(def-source-transform cddddr (x) `(cdr (cdr (cdr (cdr ,x))))) + +(defun source-transform-cxr (form) + (if (or *byte-compiling* (/= (length form) 2)) + (values nil t) + (let ((name (symbol-name (car form)))) + (do ((i (- (length name) 2) (1- i)) + (res (cadr form) + `(,(ecase (char name i) + (#\A 'car) + (#\D 'cdr)) + ,res))) + ((zerop i) res))))) + +(do ((i 2 (1+ i)) + (b '(1 0) (cons i b))) + ((= i 5)) + (dotimes (j (ash 1 i)) + (setf (info function source-transform + (intern (format nil "C~{~:[A~;D~]~}R" + (mapcar #'(lambda (x) (logbitp x j)) b)))) + #'source-transform-cxr))) ;;; ;;; Turn First..Fourth and Rest into the obvious synonym, assuming whatever is @@ -875,7 +868,7 @@ ;;; Handle the case of a constant boole-code. ;;; -(deftransform boole ((op x y)) +(deftransform boole ((op x y) * * :when :both) "convert to inline logical ops" (unless (constant-continuation-p op) (give-up "BOOLE code is not a constant.")) @@ -905,7 +898,7 @@ ;;; If arg is a constant power of two, turn * into a shift. ;;; -(deftransform * ((x y) (integer integer)) +(deftransform * ((x y) (integer integer) * :when :both) "convert x*2^k to shift" (unless (constant-continuation-p y) (give-up)) (let* ((y (continuation-value y)) @@ -981,17 +974,17 @@ (- (logand (- x) ,mask))) `(values (ash x ,shift) (logand x ,mask)))))))) - (deftransform floor ((x y) (integer integer)) + (deftransform floor ((x y) (integer integer) *) "convert division by 2^k to shift" (frob y nil)) - (deftransform ceiling ((x y) (integer integer)) + (deftransform ceiling ((x y) (integer integer) *) "convert division by 2^k to shift" (frob y t))) ;;; Do the same for mod. ;;; -(deftransform mod ((x y) (integer integer)) +(deftransform mod ((x y) (integer integer) * :when :both) "convert remainder mod 2^k to LOGAND" (unless (constant-continuation-p y) (give-up)) (let* ((y (continuation-value y)) @@ -1027,7 +1020,7 @@ ;;; And the same for rem. ;;; -(deftransform rem ((x y) (integer integer)) +(deftransform rem ((x y) (integer integer) * :when :both) "convert remainder mod 2^k to LOGAND" (unless (constant-continuation-p y) (give-up)) (let* ((y (continuation-value y)) @@ -1055,7 +1048,7 @@ (logxor 0 x))) (destructuring-bind (name identity result) stuff (deftransform name ((x y) `(* (constant-argument (member ,identity))) '* - :eval-name t) + :eval-name t :when :both) "fold identity operations" result))) @@ -1063,11 +1056,13 @@ ;;; 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-argument (member 0)) rational)) +(deftransform - ((x y) ((constant-argument (member 0)) rational) * + :when :both) "convert (- 0 x) to negate" '(%negate y)) ;;; -(deftransform * ((x y) (rational (constant-argument (member 0)))) +(deftransform * ((x y) (rational (constant-argument (member 0))) * + :when :both) "convert (* x 0) to 0." 0) @@ -1094,7 +1089,8 @@ (- x) (expt 1))) (destructuring-bind (name result) stuff - (deftransform name ((x y) '(t (constant-argument t)) '* :eval-name t) + (deftransform name ((x y) '(t (constant-argument t)) '* :eval-name t + :when :both) "fold zero arg" (let ((val (continuation-value y))) (unless (and (zerop val) @@ -1109,7 +1105,8 @@ (/ x (%negate x)) (expt x (/ 1 x)))) (destructuring-bind (name result minus-result) stuff - (deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t) + (deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t + :when :both) "fold identity operations" (let ((val (continuation-value y))) (unless (and (= (abs val) 1) @@ -1171,7 +1168,8 @@ ;;; there is no intersection between the types of the arguments, then the ;;; result is definitely false. ;;; -(deftransform simple-equality-transform ((x y) * * :defun-only t) +(deftransform simple-equality-transform ((x y) * * :defun-only t + :when :both) (cond ((same-leaf-ref-p x y) 't) ((not (types-intersect (continuation-type x) (continuation-type y))) @@ -1198,7 +1196,7 @@ ;;; -- If Y is a fixnum, then we quietly pass because the back end can handle ;;; that case, otherwise give an efficency note. ;;; -(deftransform eql ((x y)) +(deftransform eql ((x y) * * :when :both) "convert to simpler equality predicate" (let ((x-type (continuation-type x)) (y-type (continuation-type y)) @@ -1230,7 +1228,7 @@ ;;; either both rational or both floats of the same format. Complexp must also ;;; be specified and identical. ;;; -(deftransform = ((x y)) +(deftransform = ((x y) * * :when :both) "open code" (let ((x-type (continuation-type x)) (y-type (continuation-type y))) @@ -1289,10 +1287,10 @@ (give-up)))))) -(deftransform < ((x y) (integer integer)) +(deftransform < ((x y) (integer integer) * :when :both) (ir1-transform-< x y x y '>)) -(deftransform > ((x y) (integer integer)) +(deftransform > ((x y) (integer integer) * :when :both) (ir1-transform-< y x x y '<)) @@ -1511,7 +1509,8 @@ ;;; string is a function (i.e. formatter), then convert the call to format to ;;; just a funcall of that function. ;;; -(deftransform format ((dest control &rest args) (t simple-string &rest t)) +(deftransform format ((dest control &rest args) (t simple-string &rest t) * + :policy (> speed space)) (unless (constant-continuation-p control) (give-up "Control string is not a constant.")) (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args))) @@ -1519,13 +1518,15 @@ (declare (ignore control)) (format dest (formatter ,(continuation-value control)) ,@arg-names)))) ;;; -(deftransform format ((stream control &rest args) (stream function &rest t)) +(deftransform format ((stream control &rest args) (stream function &rest t) * + :policy (> speed space)) (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args))) `(lambda (stream control ,@arg-names) (funcall control stream ,@arg-names) nil))) ;;; -(deftransform format ((tee control &rest args) ((member t) function &rest t)) +(deftransform format ((tee control &rest args) ((member t) function &rest t) * + :policy (> speed space)) (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args))) `(lambda (tee control ,@arg-names) (declare (ignore tee)) diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp index 1ca78e94e..27cd0b844 100644 --- a/compiler/typetran.lisp +++ b/compiler/typetran.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/typetran.lisp,v 1.18 1993/03/13 17:27:23 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.19 1993/05/11 13:50:58 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -425,32 +425,35 @@ ;;; If the type is Type= to a type that has a predicate, then expand to that ;;; predicate. Otherwise, we dispatch off of the type's type. These ;;; transformations can increase space, but it is hard to tell when, so we -;;; ignore policy and always do them. +;;; ignore policy and always do them. When byte-compiling, we only do +;;; transforms that have potential for control simplification. ;;; (def-source-transform typep (object spec) (if (and (consp spec) (eq (car spec) 'quote)) - (let* ((type (specifier-type (cadr spec))) - (pred (cdr (assoc type (backend-type-predicates *backend*) - :test #'type=)))) - (if pred - `(,pred ,object) + (let ((type (specifier-type (cadr spec)))) + (or (let ((pred (cdr (assoc type (backend-type-predicates *backend*) + :test #'type=)))) + (when pred `(,pred ,object))) (typecase type - (numeric-type - (source-transform-numeric-typep object type)) (hairy-type (source-transform-hairy-typep object type)) (union-type (source-transform-union-typep object type)) (member-type `(member ,object ',(member-type-members type))) - (class - (source-transform-instance-typep object type)) (args-type (compiler-warning "Illegal type specifier for Typep: ~S." (cadr spec)) `(%typep ,object ,spec)) - (array-type - (source-transform-array-typep object type)) - (t - `(%typep ,object ,spec))))) + (t nil)) + (and (not *byte-compiling*) + (typecase type + (numeric-type + (source-transform-numeric-typep object type)) + (class + (source-transform-instance-typep object type)) + (array-type + (source-transform-array-typep object type)) + (t nil))) + `(%typep ,object ,spec))) (values nil t))) -- GitLab