;;;; This file contains macro-like source transformations which
;;;; convert uses of certain functions into the canonical form desired
-;;;; within the compiler. ### and other IR1 transforms and stuff.
+;;;; within the compiler. FIXME: and other IR1 transforms and stuff.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;; lambda with the appropriate fixed number of args. If the
;;; destination is a FUNCALL, then do the &REST APPLY thing, and let
;;; MV optimization figure things out.
-(deftransform complement ((fun) * * :node node :when :both)
+(deftransform complement ((fun) * * :node node)
"open code"
(multiple-value-bind (min max)
(fun-type-nargs (continuation-type fun))
(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
(define-source-transform logbitp (index integer)
`(not (zerop (logand (ash 1 ,index) ,integer))))
-(define-source-transform byte (size position) `(cons ,size ,position))
+(define-source-transform byte (size position)
+ `(cons ,size ,position))
(define-source-transform byte-size (spec) `(car ,spec))
(define-source-transform byte-position (spec) `(cdr ,spec))
(define-source-transform ldb-test (bytespec integer)
(defun interval-bounded-p (x how)
(declare (type interval x))
(ecase how
- ('above
+ (above
(interval-high x))
- ('below
+ (below
(interval-low x))
- ('both
+ (both
(and (interval-low x) (interval-high x)))))
;;; signed zero comparison functions. Use these functions if we need
(defun interval-abs (x)
(declare (type interval x))
(case (interval-range-info x)
- ('+
+ (+
(copy-interval x))
- ('-
+ (-
(interval-neg x))
(t
(destructuring-bind (x- x+) (interval-split 0 x t t)
"place constant arg last"))
;;; Handle the case of a constant BOOLE-CODE.
-(deftransform boole ((op x y) * * :when :both)
+(deftransform boole ((op x y) * *)
"convert to inline logical operations"
(unless (constant-continuation-p op)
(give-up-ir1-transform "BOOLE code is not a constant."))
;;;; converting special case multiply/divide to shifts
;;; If arg is a constant power of two, turn * into a shift.
-(deftransform * ((x y) (integer integer) * :when :both)
+(deftransform * ((x y) (integer integer) *)
"convert x*2^k to shift"
(unless (constant-continuation-p y)
(give-up-ir1-transform))
(frob y t)))
;;; Do the same for MOD.
-(deftransform mod ((x y) (integer integer) * :when :both)
+(deftransform mod ((x y) (integer integer) *)
"convert remainder mod 2^k to LOGAND"
(unless (constant-continuation-p y)
(give-up-ir1-transform))
(logand x ,mask))))))
;;; And the same for REM.
-(deftransform rem ((x y) (integer integer) * :when :both)
+(deftransform rem ((x y) (integer integer) *)
"convert remainder mod 2^k to LOGAND"
(unless (constant-continuation-p y)
(give-up-ir1-transform))
;;; Flush calls to various arith functions that convert to the
;;; identity function or a constant.
(macrolet ((def (name identity result)
- `(deftransform ,name ((x y) (* (constant-arg (member ,identity)))
- * :when :both)
+ `(deftransform ,name ((x y) (* (constant-arg (member ,identity))) *)
"fold identity operations"
',result)))
(def ash 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-arg (member 0)) rational) *
- :when :both)
+(deftransform - ((x y) ((constant-arg (member 0)) rational) *)
"convert (- 0 x) to negate"
'(%negate y))
-(deftransform * ((x y) (rational (constant-arg (member 0))) *
- :when :both)
+(deftransform * ((x y) (rational (constant-arg (member 0))) *)
"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-arg t)) * :when :both)
+(deftransform + ((x y) (t (constant-arg t)) *)
"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-arg t)) * :when :both)
+(deftransform - ((x y) (t (constant-arg t)) *)
"fold zero arg"
(let ((val (continuation-value y)))
(unless (and (zerop val)
;;; Fold (OP x +/-1)
(macrolet ((def (name result minus-result)
- `(deftransform ,name ((x y) (t (constant-arg real))
- * :when :both)
+ `(deftransform ,name ((x y) (t (constant-arg real)) *)
"fold identity operations"
(let ((val (continuation-value y)))
(unless (and (= (abs val) 1)
;;; 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)
(macrolet ((def (name)
`(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
- * :when :both)
+ *)
"fold zero arg"
'(values 0 0))))
(def truncate)
;;; if 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
- :when :both)
+ :defun-only t)
(cond ((same-leaf-ref-p x y)
t)
((not (types-equal-or-intersect (continuation-type x)
;;; these interesting cases.
;;; -- If Y is a fixnum, then we quietly pass because the back end can
;;; handle that case, otherwise give an efficiency note.
-(deftransform eql ((x y) * * :when :both)
+(deftransform eql ((x y) * *)
"convert to simpler equality predicate"
(let ((x-type (continuation-type x))
(y-type (continuation-type y))
;;; Convert to EQL if both args are rational and complexp is specified
;;; and the same for both.
-(deftransform = ((x y) * * :when :both)
+(deftransform = ((x y) * *)
"open code"
(let ((x-type (continuation-type x))
(y-type (continuation-type y)))
(t
(give-up-ir1-transform))))))
-(deftransform < ((x y) (integer integer) * :when :both)
+(deftransform < ((x y) (integer integer) *)
(ir1-transform-< x y x y '>))
-(deftransform > ((x y) (integer integer) * :when :both)
+(deftransform > ((x y) (integer integer) *)
(ir1-transform-< y x x y '<))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(deftransform < ((x y) (float float) * :when :both)
+(deftransform < ((x y) (float float) *)
(ir1-transform-< x y x y '>))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(deftransform > ((x y) (float float) * :when :both)
+(deftransform > ((x y) (float float) *)
(ir1-transform-< y x x y '<))
\f
;;;; converting N-arg comparisons
(define-source-transform char-not-equal (&rest args)
(multi-not-equal 'char-equal args))
+;;; FIXME: can go away once bug 194 is fixed and we can use (THE REAL X)
+;;; as God intended
+(defun error-not-a-real (x)
+ (error 'simple-type-error
+ :datum x
+ :expected-type 'real
+ :format-control "not a REAL: ~S"
+ :format-arguments (list x)))
+
;;; Expand MAX and MIN into the obvious comparisons.
-(define-source-transform max (arg &rest more-args)
- (if (null more-args)
- `(values ,arg)
- (once-only ((arg1 arg)
- (arg2 `(max ,@more-args)))
- `(if (> ,arg1 ,arg2)
- ,arg1 ,arg2))))
-(define-source-transform min (arg &rest more-args)
- (if (null more-args)
- `(values ,arg)
- (once-only ((arg1 arg)
- (arg2 `(min ,@more-args)))
- `(if (< ,arg1 ,arg2)
- ,arg1 ,arg2))))
+(define-source-transform max (arg0 &rest rest)
+ (once-only ((arg0 arg0))
+ (if (null rest)
+ `(values (the real ,arg0))
+ `(let ((maxrest (max ,@rest)))
+ (if (> ,arg0 maxrest) ,arg0 maxrest)))))
+(define-source-transform min (arg0 &rest rest)
+ (once-only ((arg0 arg0))
+ (if (null rest)
+ `(values (the real ,arg0))
+ `(let ((minrest (min ,@rest)))
+ (if (< ,arg0 minrest) ,arg0 minrest)))))
\f
;;;; converting N-arg arithmetic functions
;;;;
;;; Do source transformations for transitive functions such as +.
;;; One-arg cases are replaced with the arg and zero arg cases with
-;;; the identity. If LEAF-FUN is true, then replace two-arg calls with
-;;; a call to that function.
-(defun source-transform-transitive (fun args identity &optional leaf-fun)
+;;; the identity. ONE-ARG-RESULT-TYPE is, if non-NIL, the type to
+;;; ensure (with THE) that the argument in one-argument calls is.
+(defun source-transform-transitive (fun args identity
+ &optional one-arg-result-type)
(declare (symbol fun leaf-fun) (list args))
(case (length args)
(0 identity)
- (1 `(values ,(first args)))
- (2 (if leaf-fun
- `(,leaf-fun ,(first args) ,(second args))
- (values nil t)))
+ (1 (if one-arg-result-type
+ `(values (the ,one-arg-result-type ,(first args)))
+ `(values ,(first args))))
+ (2 (values nil t))
(t
(associate-args fun (first args) (rest args)))))
(define-source-transform + (&rest args)
- (source-transform-transitive '+ args 0))
+ (source-transform-transitive '+ args 0 'number))
(define-source-transform * (&rest args)
- (source-transform-transitive '* args 1))
+ (source-transform-transitive '* args 1 'number))
(define-source-transform logior (&rest args)
- (source-transform-transitive 'logior args 0))
+ (source-transform-transitive 'logior args 0 'integer))
(define-source-transform logxor (&rest args)
- (source-transform-transitive 'logxor args 0))
+ (source-transform-transitive 'logxor args 0 'integer))
(define-source-transform logand (&rest args)
- (source-transform-transitive 'logand args -1))
+ (source-transform-transitive 'logand args -1 'integer))
(define-source-transform logeqv (&rest args)
(if (evenp (length args))
;;; Do source transformations for intransitive n-arg functions such as
;;; /. With one arg, we form the inverse. With two args we pass.
;;; Otherwise we associate into two-arg calls.
-(declaim (ftype (function (symbol list t) list) source-transform-intransitive))
+(declaim (ftype (function (symbol list t)
+ (values list &optional (member nil t)))
+ source-transform-intransitive))
(defun source-transform-intransitive (function args inverse)
(case (length args)
((0 2) (values nil t))
*universal-type*)))))
(defoptimizer (array-element-type derive-type) ((array))
- (let* ((array-type (continuation-type array)))
+ (let ((array-type (continuation-type array)))
(labels ((consify (list)
(if (endp list)
'(eql nil)