;;;; and eliminates the need for any VM-dependent transforms to handle
;;;; these cases.
-(dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1
- bit-andc2 bit-orc1 bit-orc2))
- ;; Make a result array if result is NIL or unsupplied.
- (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array)
- '(bit-vector bit-vector &optional null) '*
- :eval-name t
- :policy (>= speed space))
- `(,fun bit-array-1 bit-array-2
- (make-array (length bit-array-1) :element-type 'bit)))
- ;; If result is T, make it the first arg.
- (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)
- '(bit-vector bit-vector (member t)) '*
- :eval-name t)
- `(,fun bit-array-1 bit-array-2 bit-array-1)))
+(macrolet ((def-frob (fun)
+ `(progn
+ (deftransform ,fun ((bit-array-1 bit-array-2 &optional result-bit-array)
+ (bit-vector bit-vector &optional null) *
+ :policy (>= speed space))
+ `(,',fun bit-array-1 bit-array-2
+ (make-array (length bit-array-1) :element-type 'bit)))
+ ;; If result is T, make it the first arg.
+ (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array)
+ (bit-vector bit-vector (member t)) *)
+ `(,',fun bit-array-1 bit-array-2 bit-array-1)))))
+ (def-frob bit-and)
+ (def-frob bit-ior)
+ (def-frob bit-xor)
+ (def-frob bit-eqv)
+ (def-frob bit-nand)
+ (def-frob bit-nor)
+ (def-frob bit-andc1)
+ (def-frob bit-andc2)
+ (def-frob bit-orc1)
+ (def-frob bit-orc2))
;;; Similar for BIT-NOT, but there is only one arg...
(deftransform bit-not ((bit-array-1 &optional result-bit-array)
(double-float) double-float
(movable foldable flushable))
-(dolist (stuff '((exp %exp *)
- (log %log float)
- (sqrt %sqrt float)
- (asin %asin float)
- (acos %acos float)
- (atan %atan *)
- (sinh %sinh *)
- (cosh %cosh *)
- (tanh %tanh *)
- (asinh %asinh *)
- (acosh %acosh float)
- (atanh %atanh float)))
- (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 :when :both)
- `(,prim x))))
+(macrolet ((def-frob (name prim rtype)
+ `(progn
+ (deftransform ,name ((x) (single-float) ,rtype)
+ `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+ (deftransform ,name ((x) (double-float) ,rtype :when :both)
+ `(,',prim x)))))
+ (def-frob exp %exp *)
+ (def-frob log %log float)
+ (def-frob sqrt %sqrt float)
+ (def-frob asin %asin float)
+ (def-frob acos %acos float)
+ (def-frob atan %atan *)
+ (def-frob sinh %sinh *)
+ (def-frob cosh %cosh *)
+ (def-frob tanh %tanh *)
+ (def-frob asinh %asinh *)
+ (def-frob acosh %acosh float)
+ (def-frob atanh %atanh float))
;;; The argument range is limited on the x86 FP trig. functions. A
;;; post-test can detect a failure (and load a suitable result), but
;;; this test is avoided if possible.
-(dolist (stuff '((sin %sin %sin-quick)
- (cos %cos %cos-quick)
- (tan %tan %tan-quick)))
- (destructuring-bind (name prim prim-quick) stuff
- (declare (ignorable prim-quick))
- (deftransform name ((x) '(single-float) '* :eval-name t)
- #!+x86 (cond ((csubtypep (continuation-type x)
- (specifier-type '(single-float
- (#.(- (expt 2f0 64)))
- (#.(expt 2f0 64)))))
- `(coerce (,prim-quick (coerce x 'double-float))
- 'single-float))
- (t
- (compiler-note
- "unable to avoid inline argument range check~@
- because the argument range (~S) was not within 2^64"
- (type-specifier (continuation-type x)))
- `(coerce (,prim (coerce x 'double-float)) 'single-float)))
- #!-x86 `(coerce (,prim (coerce x 'double-float)) 'single-float))
- (deftransform name ((x) '(double-float) '* :eval-name t :when :both)
- #!+x86 (cond ((csubtypep (continuation-type x)
- (specifier-type '(double-float
- (#.(- (expt 2d0 64)))
- (#.(expt 2d0 64)))))
- `(,prim-quick x))
- (t
- (compiler-note
- "unable to avoid inline argument range check~@
- because the argument range (~S) was not within 2^64"
- (type-specifier (continuation-type x)))
- `(,prim x)))
- #!-x86 `(,prim x))))
+(macrolet ((def-frob (name prim prim-quick)
+ (declare (ignorable prim-quick))
+ `(progn
+ (deftransform ,name ((x) (single-float) *)
+ #!+x86 (cond ((csubtypep (continuation-type x)
+ (specifier-type '(single-float
+ (#.(- (expt 2f0 64)))
+ (#.(expt 2f0 64)))))
+ `(coerce (,',prim-quick (coerce x 'double-float))
+ 'single-float))
+ (t
+ (compiler-note
+ "unable to avoid inline argument range check~@
+ because the argument range (~S) was not within 2^64"
+ (type-specifier (continuation-type x)))
+ `(coerce (,',prim (coerce x 'double-float)) 'single-float)))
+ #!-x86 `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+ (deftransform ,name ((x) (double-float) * :when :both)
+ #!+x86 (cond ((csubtypep (continuation-type x)
+ (specifier-type '(double-float
+ (#.(- (expt 2d0 64)))
+ (#.(expt 2d0 64)))))
+ `(,',prim-quick x))
+ (t
+ (compiler-note
+ "unable to avoid inline argument range check~@
+ because the argument range (~S) was not within 2^64"
+ (type-specifier (continuation-type x)))
+ `(,',prim x)))
+ #!-x86 `(,',prim x)))))
+ (def-frob sin %sin %sin-quick)
+ (def-frob cos %cos %cos-quick)
+ (def-frob tan %tan %tan-quick))
(deftransform atan ((x y) (single-float single-float) *)
`(coerce (%atan2 (coerce x 'double-float) (coerce y 'double-float))
;;; does 32 bits at a time.
;;;
;;; FIXME: This is a lot of repeatedly macroexpanded code. It should be a
-;;; function call instead. And do it with DEF-FROB instead of DOLIST.
-(dolist (x '((bit-and 32bit-logical-and)
- (bit-ior 32bit-logical-or)
- (bit-xor 32bit-logical-xor)
- (bit-eqv 32bit-logical-eqv)
- (bit-nand 32bit-logical-nand)
- (bit-nor 32bit-logical-nor)
- (bit-andc1 32bit-logical-andc1)
- (bit-andc2 32bit-logical-andc2)
- (bit-orc1 32bit-logical-orc1)
- (bit-orc2 32bit-logical-orc2)))
- (destructuring-bind (bitfun wordfun) x
- (deftransform bitfun
- ((bit-array-1 bit-array-2 result-bit-array)
- '(simple-bit-vector simple-bit-vector simple-bit-vector) '*
- :eval-name t :node node :policy (>= speed space))
- `(progn
- ,@(unless (policy node (zerop safety))
- '((unless (= (length bit-array-1) (length bit-array-2)
- (length result-bit-array))
- (error "Argument and/or result bit arrays are not the same length:~
+;;; function call instead.
+(macrolet ((def-frob (bitfun wordfun)
+ `(deftransform ,bitfun ((bit-array-1 bit-array-2 result-bit-array)
+ (simple-bit-vector simple-bit-vector simple-bit-vector) *
+ :node node :policy (>= speed space))
+ `(progn
+ ,@(unless (policy node (zerop safety))
+ '((unless (= (length bit-array-1) (length bit-array-2)
+ (length result-bit-array))
+ (error "Argument and/or result bit arrays are not the same length:~
~% ~S~% ~S ~% ~S"
- bit-array-1 bit-array-2 result-bit-array))))
- (do ((index sb!vm:vector-data-offset (1+ index))
- (end (+ sb!vm:vector-data-offset
- (truncate (the index
- (+ (length bit-array-1)
- sb!vm:n-word-bits -1))
- sb!vm:n-word-bits))))
- ((= index end) result-bit-array)
- (declare (optimize (speed 3) (safety 0))
- (type index index end))
- (setf (%raw-bits result-bit-array index)
- (,wordfun (%raw-bits bit-array-1 index)
- (%raw-bits bit-array-2 index))))))))
+ bit-array-1 bit-array-2 result-bit-array))))
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (end (+ sb!vm:vector-data-offset
+ (truncate (the index
+ (+ (length bit-array-1)
+ sb!vm:n-word-bits -1))
+ sb!vm:n-word-bits))))
+ ((= index end) result-bit-array)
+ (declare (optimize (speed 3) (safety 0))
+ (type index index end))
+ (setf (%raw-bits result-bit-array index)
+ (,',wordfun (%raw-bits bit-array-1 index)
+ (%raw-bits bit-array-2 index))))))))
+ (def-frob bit-and 32bit-logical-and)
+ (def-frob bit-ior 32bit-logical-or)
+ (def-frob bit-xor 32bit-logical-xor)
+ (def-frob bit-eqv 32bit-logical-eqv)
+ (def-frob bit-nand 32bit-logical-nand)
+ (def-frob bit-nor 32bit-logical-nor)
+ (def-frob bit-andc1 32bit-logical-andc1)
+ (def-frob bit-andc2 32bit-logical-andc2)
+ (def-frob bit-orc1 32bit-logical-orc1)
+ (def-frob bit-orc2 32bit-logical-orc2))
(deftransform bit-not
((bit-array result-bit-array)
\f
;;;; transforms for converting sap relation operators
-(dolist (info '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >)))
- (destructuring-bind (sap-fun int-fun) info
- (deftransform sap-fun ((x y) '* '* :eval-name t)
- `(,int-fun (sap-int x) (sap-int y)))))
+(macrolet ((def-frob (sap-fun int-fun)
+ `(deftransform ,sap-fun ((x y) * *)
+ `(,',int-fun (sap-int x) (sap-int y)))))
+ (def-frob sap< <)
+ (def-frob sap<= <=)
+ (def-frob sap= =)
+ (def-frob sap>= >=)
+ (def-frob sap> >))
\f
;;;; transforms for optimizing SAP+
'(lambda (sap offset1 offset2)
(sap+ sap (+ offset1 offset2))))))
-(dolist (fun '(sap-ref-8 %set-sap-ref-8
- signed-sap-ref-8 %set-signed-sap-ref-8
- sap-ref-16 %set-sap-ref-16
- signed-sap-ref-16 %set-signed-sap-ref-16
- sap-ref-32 %set-sap-ref-32
- signed-sap-ref-32 %set-signed-sap-ref-32
- sap-ref-sap %set-sap-ref-sap
- sap-ref-single %set-sap-ref-single
- sap-ref-double %set-sap-ref-double
- #!+(or x86 long-float) sap-ref-long
- #!+long-float %set-sap-ref-long))
- (deftransform fun ((sap offset) '* '* :eval-name t)
- (extract-function-args sap 'sap+ 2)
- `(lambda (sap offset1 offset2)
- (,fun sap (+ offset1 offset2)))))
+(macrolet ((def-frob (fun)
+ `(deftransform ,fun ((sap offset) * *)
+ (extract-function-args sap 'sap+ 2)
+ `(lambda (sap offset1 offset2)
+ (,',fun sap (+ offset1 offset2))))))
+ (def-frob sap-ref-8)
+ (def-frob %set-sap-ref-8)
+ (def-frob signed-sap-ref-8)
+ (def-frob %set-signed-sap-ref-8)
+ (def-frob sap-ref-16)
+ (def-frob %set-sap-ref-16)
+ (def-frob signed-sap-ref-16)
+ (def-frob %set-signed-sap-ref-16)
+ (def-frob sap-ref-32)
+ (def-frob %set-sap-ref-32)
+ (def-frob signed-sap-ref-32)
+ (def-frob %set-signed-sap-ref-32)
+ (def-frob sap-ref-sap)
+ (def-frob %set-sap-ref-sap)
+ (def-frob sap-ref-single)
+ (def-frob %set-sap-ref-single)
+ (def-frob sap-ref-double)
+ (def-frob %set-sap-ref-double)
+ ;; The original CMUCL code had #!+(and x86 long-float) for this first one,
+ ;; but only #!+long-float for the second. This was redundant, since the
+ ;; LONG-FLOAT target feature only exists on X86. So we removed the
+ ;; redundancy. --njf 2002-01-08
+ #!+long-float (def-frob sap-ref-long)
+ #!+long-float (def-frob %set-sap-ref-long))
(deftransform %setelt ((s i v) (list * *))
'(setf (car (nthcdr i s)) v))
-;;; FIXME: The MACROLET ... DEF-FROB ... DEFTRANSFORM idioms in this
-;;; file are literal translations of old CMU CL DOLIST ... DEFTRANSFORM,
-;;; and so use :EVAL-NAME for historical reasons. It'd be tidier to
-;;; just let macroexpansion substitution take care of everything,
-;;; and remove both :EVAL-NAME and the extra layer of quotes.
-
(macrolet ((def-frob (name)
- `(deftransform ',name ((e l &key (test #'eql)) '* '* :node node :when :both
- :eval-name t)
+ `(deftransform ,name ((e l &key (test #'eql)) * * :node node :when :both)
(unless (constant-continuation-p l)
(give-up-ir1-transform))
;;; this was done, a few bytes could be saved by a call to a shared
;;; function. This remains to be done.
(macrolet ((def-frob (fun eq-fun)
- `(deftransform ',fun ((item list &key test) '(t list &rest t) '*
- :eval-name t)
+ `(deftransform ,fun ((item list &key test) (t list &rest t) *)
"convert to EQ test"
;; FIXME: The scope of this transformation could be
;; widened somewhat, letting it work whenever the test is
;;; version. This is an IR1 transform so that we don't have to worry about
;;; changing the order of evaluation.
(macrolet ((def-frob (fun pred*)
- `(deftransform ',fun ((string1 string2 &key (start1 0) end1
+ `(deftransform ,fun ((string1 string2 &key (start1 0) end1
(start2 0) end2)
- '* '* :eval-name t)
+ * *)
`(,',pred* string1 string2 start1 end1 start2 end2))))
(def-frob string< string<*)
(def-frob string> string>*)
;;; start and end are also gotten from the environment. Both strings
;;; must be SIMPLE-STRINGs.
(macrolet ((def-frob (name lessp equalp)
- `(deftransform ',name ((string1 string2 start1 end1 start2 end2)
- '(simple-string simple-string t t t t) '*
- :eval-name t)
+ `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+ (simple-string simple-string t t t t) *)
`(let* ((end1 (if (not end1) (length string1) end1))
(end2 (if (not end2) (length string2) end2))
(index (sb!impl::%sp-string-compare
(def-frob string>=* nil t))
(macrolet ((def-frob (name result-fun)
- `(deftransform ',name ((string1 string2 start1 end1 start2 end2)
- '(simple-string simple-string t t t t) '*
- :eval-name t)
+ `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+ (simple-string simple-string t t t t) *)
`(,',result-fun
(sb!impl::%sp-string-compare
string1 start1 (or end1 (length string1))
;;; Flush calls to various arith functions that convert to the
;;; identity function or a constant.
-;;;
-;;; FIXME: Rewrite as DEF-FROB.
-(dolist (stuff '((ash 0 x)
- (logand -1 x)
- (logand 0 0)
- (logior 0 x)
- (logior -1 -1)
- (logxor -1 (lognot x))
- (logxor 0 x)))
- (destructuring-bind (name identity result) stuff
- (deftransform name ((x y) `(* (constant-argument (member ,identity))) '*
- :eval-name t :when :both)
- "fold identity operations"
- result)))
+(macrolet ((def-frob (name identity result)
+ `(deftransform ,name ((x y) (* (constant-argument (member ,identity)))
+ * :when :both)
+ "fold identity operations"
+ ',result)))
+ (def-frob ash 0 x)
+ (def-frob logand -1 x)
+ (def-frob logand 0 0)
+ (def-frob logior 0 x)
+ (def-frob logior -1 -1)
+ (def-frob logxor -1 (lognot x))
+ (def-frob logxor 0 x))
;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
;;; (* 0 -4.0) is -0.0.
'x)
;;; Fold (OP x +/-1)
-(dolist (stuff '((* x (%negate x))
- (/ 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
- :when :both)
- "fold identity operations"
- (let ((val (continuation-value y)))
- (unless (and (= (abs val) 1)
- (not-more-contagious y x))
- (give-up-ir1-transform))
- (if (minusp val) minus-result result)))))
+(macrolet ((def-frob (name result minus-result)
+ `(deftransform ,name ((x y) (t (constant-argument real))
+ * :when :both)
+ "fold identity operations"
+ (let ((val (continuation-value y)))
+ (unless (and (= (abs val) 1)
+ (not-more-contagious y x))
+ (give-up-ir1-transform))
+ (if (minusp val) ',minus-result ',result)))))
+ (def-frob * x (%negate x))
+ (def-frob / x (%negate x))
+ (def-frob expt x (/ 1 x)))
;;; Fold (expt x n) into multiplications for small integral values of
;;; N; convert (expt x 1/2) to sqrt.
;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
;;; transformations?
;;; Perhaps we should have to prove that the denominator is nonzero before
-;;; doing them? (Also the DOLIST over macro calls is weird. Perhaps
-;;; just FROB?) -- WHN 19990917
-;;;
-;;; FIXME: What gives with the single quotes in the argument lists
-;;; for DEFTRANSFORMs here? Does that work? Is it needed? Why?
-(dolist (name '(ash /))
- (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
- :eval-name t :when :both)
- "fold zero arg"
- 0))
-(dolist (name '(truncate round floor ceiling))
- (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
- :eval-name t :when :both)
- "fold zero arg"
- '(values 0 0)))
+;;; doing them? -- WHN 19990917
+(macrolet ((def-frob (name)
+ `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer)
+ * :when :both)
+ "fold zero arg"
+ 0)))
+ (def-frob ash)
+ (def-frob /))
+
+(macrolet ((def-frob (name)
+ `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer)
+ * :when :both)
+ "fold zero arg"
+ '(values 0 0))))
+ (def-frob truncate)
+ (def-frob round)
+ (def-frob floor)
+ (def-frob ceiling))
+
\f
;;;; character operations
(t
(give-up-ir1-transform))))
-(dolist (x '(eq char= equal))
- (%deftransform x '(function * *) #'simple-equality-transform))
+(macrolet ((def-frob (x)
+ `(%deftransform ',x '(function * *) #'simple-equality-transform)))
+ (def-frob eq)
+ (def-frob char=)
+ (def-frob equal))
;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
;;; try to convert to a type-specific predicate or EQ:
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.120"
+"0.pre7.121"
projects / sbcl.git / commitdiff