;;; Define optimizers for FLOOR and CEILING.
(macrolet
- ((frob-opt (name q-name r-name)
+ ((def (name q-name r-name)
(let ((q-aux (symbolicate q-name "-AUX"))
(r-aux (symbolicate r-name "-AUX")))
`(progn
(when (and quot rem)
(make-values-type :required (list quot rem))))))))))
- ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
- (frob-opt floor floor-quotient-bound floor-rem-bound)
- (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound))
+ (def floor floor-quotient-bound floor-rem-bound)
+ (def ceiling ceiling-quotient-bound ceiling-rem-bound))
;;; Define optimizers for FFLOOR and FCEILING
-(macrolet
- ((frob-opt (name q-name r-name)
- (let ((q-aux (symbolicate "F" q-name "-AUX"))
- (r-aux (symbolicate r-name "-AUX")))
- `(progn
- ;; Compute type of quotient (first) result.
- (defun ,q-aux (number-type divisor-type)
- (let* ((number-interval
- (numeric-type->interval number-type))
- (divisor-interval
- (numeric-type->interval divisor-type))
- (quot (,q-name (interval-div number-interval
- divisor-interval)))
- (res-type (numeric-contagion number-type divisor-type)))
- (make-numeric-type
- :class (numeric-type-class res-type)
- :format (numeric-type-format res-type)
- :low (interval-low quot)
- :high (interval-high quot))))
-
- (defoptimizer (,name derive-type) ((number divisor))
- (flet ((derive-q (n d same-arg)
- (declare (ignore same-arg))
- (if (and (numeric-type-real-p n)
- (numeric-type-real-p d))
- (,q-aux n d)
- *empty-type*))
- (derive-r (n d same-arg)
- (declare (ignore same-arg))
- (if (and (numeric-type-real-p n)
- (numeric-type-real-p d))
- (,r-aux n d)
- *empty-type*)))
- (let ((quot (two-arg-derive-type
- number divisor #'derive-q #',name))
- (rem (two-arg-derive-type
- number divisor #'derive-r #'mod)))
- (when (and quot rem)
- (make-values-type :required (list quot rem))))))))))
-
- ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
- (frob-opt ffloor floor-quotient-bound floor-rem-bound)
- (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))
+(macrolet ((def (name q-name r-name)
+ (let ((q-aux (symbolicate "F" q-name "-AUX"))
+ (r-aux (symbolicate r-name "-AUX")))
+ `(progn
+ ;; Compute type of quotient (first) result.
+ (defun ,q-aux (number-type divisor-type)
+ (let* ((number-interval
+ (numeric-type->interval number-type))
+ (divisor-interval
+ (numeric-type->interval divisor-type))
+ (quot (,q-name (interval-div number-interval
+ divisor-interval)))
+ (res-type (numeric-contagion number-type
+ divisor-type)))
+ (make-numeric-type
+ :class (numeric-type-class res-type)
+ :format (numeric-type-format res-type)
+ :low (interval-low quot)
+ :high (interval-high quot))))
+
+ (defoptimizer (,name derive-type) ((number divisor))
+ (flet ((derive-q (n d same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-real-p n)
+ (numeric-type-real-p d))
+ (,q-aux n d)
+ *empty-type*))
+ (derive-r (n d same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-real-p n)
+ (numeric-type-real-p d))
+ (,r-aux n d)
+ *empty-type*)))
+ (let ((quot (two-arg-derive-type
+ number divisor #'derive-q #',name))
+ (rem (two-arg-derive-type
+ number divisor #'derive-r #'mod)))
+ (when (and quot rem)
+ (make-values-type :required (list quot rem))))))))))
+
+ (def ffloor floor-quotient-bound floor-rem-bound)
+ (def fceiling ceiling-quotient-bound ceiling-rem-bound))
;;; functions to compute the bounds on the quotient and remainder for
;;; the FLOOR function
(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 (name identity result)
+ `(deftransform ,name ((x y) (* (constant-arg (member ,identity)))
+ * :when :both)
+ "fold identity operations"
+ ',result)))
+ (def ash 0 x)
+ (def logand -1 x)
+ (def logand 0 0)
+ (def logior 0 x)
+ (def logior -1 -1)
+ (def logxor -1 (lognot x))
+ (def 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 (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 * x (%negate x))
+ (def / x (%negate x))
+ (def 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 (name)
+ `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
+ * :when :both)
+ "fold zero arg"
+ 0)))
+ (def ash)
+ (def /))
+
+(macrolet ((def (name)
+ `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
+ * :when :both)
+ "fold zero arg"
+ '(values 0 0))))
+ (def truncate)
+ (def round)
+ (def floor)
+ (def ceiling))
\f
;;;; character operations
(t
(give-up-ir1-transform))))
-(dolist (x '(eq char= equal))
- (%deftransform x '(function * *) #'simple-equality-transform))
+(macrolet ((def (x)
+ `(%deftransform ',x '(function * *) #'simple-equality-transform)))
+ (def eq)
+ (def char=)
+ (def equal))
;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
;;; try to convert to a type-specific predicate or EQ:
;;;; versions, and degenerate cases are flushed.
;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
-(declaim (ftype (function (symbol t list) list) associate-arguments))
-(defun associate-arguments (function first-arg more-args)
+(declaim (ftype (function (symbol t list) list) associate-args))
+(defun associate-args (function first-arg more-args)
(let ((next (rest more-args))
(arg (first more-args)))
(if (null next)
`(,function ,first-arg ,arg)
- (associate-arguments function `(,function ,first-arg ,arg) next))))
+ (associate-args function `(,function ,first-arg ,arg) next))))
;;; Do source transformations for transitive functions such as +.
;;; One-arg cases are replaced with the arg and zero arg cases with
`(,leaf-fun ,(first args) ,(second args))
(values nil t)))
(t
- (associate-arguments fun (first args) (rest args)))))
+ (associate-args fun (first args) (rest args)))))
(define-source-transform + (&rest args)
(source-transform-transitive '+ args 0))
(0 0)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
- (t (associate-arguments 'gcd (first args) (rest args)))))
+ (t (associate-args 'gcd (first args) (rest args)))))
(define-source-transform lcm (&rest args)
(case (length args)
(0 1)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
- (t (associate-arguments 'lcm (first args) (rest args)))))
+ (t (associate-args 'lcm (first args) (rest args)))))
;;; Do source transformations for intransitive n-arg functions such as
;;; /. With one arg, we form the inverse. With two args we pass.
(case (length args)
((0 2) (values nil t))
(1 `(,@inverse ,(first args)))
- (t (associate-arguments function (first args) (rest args)))))
+ (t (associate-args function (first args) (rest args)))))
(define-source-transform - (&rest args)
(source-transform-intransitive '- args '(%negate)))
(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