(defoptimizer (values derive-type) ((&rest values))
(values-specifier-type
- `(values ,@(mapcar #'(lambda (x)
- (type-specifier (continuation-type x)))
+ `(values ,@(mapcar (lambda (x)
+ (type-specifier (continuation-type x)))
values))))
\f
;;;; byte operations
;;; 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-arg (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.
-(deftransform - ((x y) ((constant-argument (member 0)) rational) *
+(deftransform - ((x y) ((constant-arg (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-arg (member 0))) *
:when :both)
"convert (* x 0) to 0"
0)
;;;
;;; If y is not constant, not zerop, or is contagious, or a positive
;;; float +0.0 then give up.
-(deftransform + ((x y) (t (constant-argument t)) * :when :both)
+(deftransform + ((x y) (t (constant-arg t)) * :when :both)
"fold zero arg"
(let ((val (continuation-value y)))
(unless (and (zerop val)
;;;
;;; If y is not constant, not zerop, or is contagious, or a negative
;;; float -0.0 then give up.
-(deftransform - ((x y) (t (constant-argument t)) * :when :both)
+(deftransform - ((x y) (t (constant-arg t)) * :when :both)
"fold zero arg"
(let ((val (continuation-value y)))
(unless (and (zerop val)
'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-arg 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.
-(deftransform expt ((x y) (t (constant-argument real)) *)
+(deftransform expt ((x y) (t (constant-arg real)) *)
"recode as multiplication or sqrt"
(let ((val (continuation-value y)))
;; If Y would cause the result to be promoted to the same type as
;;; 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-arg (integer 0 0)) integer)
+ * :when :both)
+ "fold zero arg"
+ 0)))
+ (def-frob ash)
+ (def-frob /))
+
+(macrolet ((def-frob (name)
+ `(deftransform ,name ((x y) ((constant-arg (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:
(define-source-transform apply (fun arg &rest more-args)
(let ((args (cons arg more-args)))
`(multiple-value-call ,fun
- ,@(mapcar #'(lambda (x)
- `(values ,x))
+ ,@(mapcar (lambda (x)
+ `(values ,x))
(butlast args))
(values-list ,(car (last args))))))
\f
projects / sbcl.git / blobdiff