(reported by Christophe Rhodes and Martin Atzmueller sbcl-devel
2002-05-15)
+160:
+ USER-HOMEDIR-PATHNAME returns a pathname that SBCL can't do anything
+ with. Probably we should return an absolute physical pathname
+ instead. (Reported by Peter van Eynde sbcl-devel 2002-03-29)
+
+161:
+ Typep on certain SATISFIES types doesn't take account of the fact
+ that the function could cause an error; e.g. (TYPEP #\! '(SATISFIES
+ FBOUNDP)) raises an error when it should return NIL.
DEFUNCT CATEGORIES OF BUGS
IR1-#:
(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) * :when :both)
+(deftransform float ((n &optional f) (* &optional single-float) *)
'(%single-float n))
-(deftransform float ((n f) (* double-float) * :when :both)
+(deftransform float ((n f) (* double-float) *)
'(%double-float n))
-(deftransform %single-float ((n) (single-float) * :when :both)
+(deftransform %single-float ((n) (single-float) *)
'n)
-(deftransform %double-float ((n) (double-float) * :when :both)
+(deftransform %double-float ((n) (double-float) *)
'n)
;;; RANDOM
(macrolet ((frob (fun type)
`(deftransform random ((num &optional state)
- (,type &optional *) *
- :when :both)
+ (,type &optional *) *)
"Use inline float operations."
'(,fun num (or state *random-state*)))))
(frob %random-single-float single-float)
(defknown scale-double-float (double-float fixnum) double-float
(movable foldable flushable))
-(deftransform decode-float ((x) (single-float) * :when :both)
+(deftransform decode-float ((x) (single-float) *)
'(decode-single-float x))
-(deftransform decode-float ((x) (double-float) * :when :both)
+(deftransform decode-float ((x) (double-float) *)
'(decode-double-float x))
-(deftransform integer-decode-float ((x) (single-float) * :when :both)
+(deftransform integer-decode-float ((x) (single-float) *)
'(integer-decode-single-float x))
-(deftransform integer-decode-float ((x) (double-float) * :when :both)
+(deftransform integer-decode-float ((x) (double-float) *)
'(integer-decode-double-float x))
-(deftransform scale-float ((f ex) (single-float *) * :when :both)
+(deftransform scale-float ((f ex) (single-float *) *)
(if (and #!+x86 t #!-x86 nil
(csubtypep (continuation-type ex)
(specifier-type '(signed-byte 32))))
'(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)
'(scale-single-float f ex)))
-(deftransform scale-float ((f ex) (double-float *) * :when :both)
+(deftransform scale-float ((f ex) (double-float *) *)
(if (and #!+x86 t #!-x86 nil
(csubtypep (continuation-type ex)
(specifier-type '(signed-byte 32))))
;;; do it for any rational that has a precise representation as a
;;; float (such as 0).
(macrolet ((frob (op)
- `(deftransform ,op ((x y) (float rational) * :when :both)
+ `(deftransform ,op ((x y) (float rational) *)
"open-code FLOAT to RATIONAL comparison"
(unless (constant-continuation-p y)
(give-up-ir1-transform
`(progn
(deftransform ,name ((x) (single-float) ,rtype)
`(coerce (,',prim (coerce x 'double-float)) 'single-float))
- (deftransform ,name ((x) (double-float) ,rtype :when :both)
+ (deftransform ,name ((x) (double-float) ,rtype)
`(,',prim x)))))
(def exp %exp *)
(def log %log float)
(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)
+ (deftransform ,name ((x) (double-float) *)
#!+x86 (cond ((csubtypep (continuation-type x)
(specifier-type '(double-float
(#.(- (expt 2d0 64)))
(deftransform atan ((x y) (single-float single-float) *)
`(coerce (%atan2 (coerce x 'double-float) (coerce y 'double-float))
'single-float))
-(deftransform atan ((x y) (double-float double-float) * :when :both)
+(deftransform atan ((x y) (double-float double-float) *)
`(%atan2 x y))
(deftransform expt ((x y) ((single-float 0f0) single-float) *)
`(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
'single-float))
-(deftransform expt ((x y) ((double-float 0d0) double-float) * :when :both)
+(deftransform expt ((x y) ((double-float 0d0) double-float) *)
`(%pow x y))
(deftransform expt ((x y) ((single-float 0f0) (signed-byte 32)) *)
`(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
'single-float))
-(deftransform expt ((x y) ((double-float 0d0) (signed-byte 32)) * :when :both)
+(deftransform expt ((x y) ((double-float 0d0) (signed-byte 32)) *)
`(%pow x (coerce y 'double-float)))
;;; ANSI says log with base zero returns zero.
\f
;;; Handle some simple transformations.
-(deftransform abs ((x) ((complex double-float)) double-float :when :both)
+(deftransform abs ((x) ((complex double-float)) double-float)
'(%hypot (realpart x) (imagpart x)))
(deftransform abs ((x) ((complex single-float)) single-float)
(coerce (imagpart x) 'double-float))
'single-float))
-(deftransform phase ((x) ((complex double-float)) double-float :when :both)
+(deftransform phase ((x) ((complex double-float)) double-float)
'(%atan2 (imagpart x) (realpart x)))
(deftransform phase ((x) ((complex single-float)) single-float)
(coerce (realpart x) 'double-float))
'single-float))
-(deftransform phase ((x) ((float)) float :when :both)
+(deftransform phase ((x) ((float)) float)
'(if (minusp (float-sign x))
(float pi x)
(float 0 x)))
;;; FUNCALL is implemented on %FUNCALL, which can only call functions
;;; (not symbols). %FUNCALL is used directly in some places where the
;;; call should always be open-coded even if FUNCALL is :NOTINLINE.
-(deftransform funcall ((function &rest args) * * :when :both)
+(deftransform funcall ((function &rest args) * *)
(let ((arg-names (make-gensym-list (length args))))
`(lambda (function ,@arg-names)
(%funcall ,(if (csubtypep (continuation-type function)
(values nil t)))
(deftransform %coerce-callable-to-fun ((thing) (function) *
- :when :both
:important t)
"optimize away possible call to FDEFINITION at runtime"
'thing)
(policy node (>= speed inhibit-warnings))
(policy node (> speed inhibit-warnings))))
(*compiler-error-context* node))
- (cond ((not (member (transform-when transform)
- '(:native :both)))
- ;; FIXME: Make sure that there's a transform for
- ;; (MEMBER SYMBOL ..) into MEMQ.
- ;; FIXME: Note that when/if I make SHARE operation to shared
- ;; constant data between objects in the system, remember that a
- ;; SHAREd list, or other SHAREd compound object, can be processed
- ;; recursively, so that e.g. the two lists above can share their
- ;; '(:BOTH) tail sublists.
- (let ((when (transform-when transform)))
- (not (or (eq when :both)
- (eq when :native))))
- t)
- ((or (not constrained)
+ (cond ((or (not constrained)
(valid-fun-use node type :strict-result t))
(multiple-value-bind (severity args)
(catch 'give-up-ir1-transform
;; string used in efficiency notes
(note (missing-arg) :type string)
;; T if we should emit a failure note even if SPEED=INHIBIT-WARNINGS.
- (important nil :type (member t nil))
- ;; usable for byte code, native code, or both?
- ;;
- ;; FIXME: Now that there's no byte compiler, this is stale and could
- ;; all go away.
- (when :native :type (member :byte :native :both)))
+ (important nil :type (member t nil)))
-(defprinter (transform) type note important when)
+(defprinter (transform) type note important)
;;; Grab the FUN-INFO and enter the function, replacing any old
;;; one with the same type and note.
(declaim (ftype (function (t list function &optional (or string null)
- (member t nil) (member :native :byte :both))
+ (member t nil))
*)
%deftransform))
-(defun %deftransform (name type fun &optional note important (when :native))
+(defun %deftransform (name type fun &optional note important)
(let* ((ctype (specifier-type type))
(note (or note "optimize"))
(info (fun-info-or-lose name))
(old (find-if (lambda (x)
(and (type= (transform-type x) ctype)
(string-equal (transform-note x) note)
- (eq (transform-important x) important)
- (eq (transform-when x) when)))
+ (eq (transform-important x) important)))
(fun-info-transforms info))))
(if old
(setf (transform-function old) fun
(transform-note old) note)
(push (make-transform :type ctype :function fun :note note
- :important important :when when)
+ :important important)
(fun-info-transforms info)))
name))
;;; which means efficiency notes will be generated when this
;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if
;;; INHIBIT-WARNINGS>SPEED).
-;;; :WHEN {:NATIVE | :BYTE | :BOTH}
-;;; - Indicates whether this transform applies to native code,
-;;; byte-code or both (default :native.)
(defmacro deftransform (name (lambda-list &optional (arg-types '*)
(result-type '*)
&key result policy node defun-only
- eval-name important (when :native))
+ eval-name important)
&body body-decls-doc)
(when (and eval-name defun-only)
(error "can't specify both DEFUN-ONLY and EVAL-NAME"))
`'(function ,arg-types ,result-type))
(lambda ,@stuff)
,doc
- ,(if important t nil)
- ,when)))))))
+ ,(if important t nil))))))))
\f
;;;; DEFKNOWN and DEFOPTIMIZER
(declare (ignorable dacc))
,push-dacc))))))))))
\f
-(deftransform elt ((s i) ((simple-array * (*)) *) * :when :both)
+(deftransform elt ((s i) ((simple-array * (*)) *) *)
'(aref s i))
-(deftransform elt ((s i) (list *) * :when :both)
+(deftransform elt ((s i) (list *) *)
'(nth i s))
-(deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both)
+(deftransform %setelt ((s i v) ((simple-array * (*)) * *) *)
'(%aset s i v))
(deftransform %setelt ((s i v) (list * *))
(macrolet ((def (name)
`(deftransform ,name ((e l &key (test #'eql)) * *
- :node node :when :both)
+ :node node)
(unless (constant-continuation-p l)
(give-up-ir1-transform))
(make-canonical-union-type (list (continuation-type x)
(continuation-type y)))))))
-(deftransform max ((x y) (number number) * :when :both)
+(deftransform max ((x y) (number number) *)
(let ((x-type (continuation-type x))
(y-type (continuation-type y))
(signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
(if (> ,arg1 ,arg2)
,arg1 ,arg2)))))))
-(deftransform min ((x y) (real real) * :when :both)
+(deftransform min ((x y) (real real) *)
(let ((x-type (continuation-type x))
(y-type (continuation-type y))
(signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
;;; 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))
"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
;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
;;; at load time.
-(deftransform find-class ((name) ((constant-arg symbol)) *
- :when :both)
+(deftransform find-class ((name) ((constant-arg symbol)) *)
(let* ((name (continuation-value name))
(cell (find-class-cell name)))
`(or (class-cell-class ',cell)
;;; then we also check whether the layout for the object is invalid
;;; and signal an error if so. Otherwise, look up the indirect
;;; class-cell and call CLASS-CELL-TYPEP at runtime.
-(deftransform %instance-typep ((object spec) (* *) * :node node :when :both)
+(deftransform %instance-typep ((object spec) (* *) * :node node)
(aver (constant-continuation-p spec))
(let* ((spec (continuation-value spec))
(class (specifier-type spec))
\f
;;;; coercion
-(deftransform coerce ((x type) (* *) * :when :both)
+(deftransform coerce ((x type) (* *) *)
(unless (constant-continuation-p type)
(give-up-ir1-transform))
(let ((tspec (specifier-type (continuation-value type))))
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.2.12"
+"0.7.2.13"
projects / sbcl.git / commitdiff