#!+sb-show
(defvar *show-transforms-p* nil)
+(defun check-important-result (node info)
+ (when (and (null (node-lvar node))
+ (ir1-attributep (fun-info-attributes info) important-result))
+ (let ((*compiler-error-context* node))
+ (compiler-style-warn
+ "The return value of ~A should not be discarded."
+ (lvar-fun-name (basic-combination-fun node))))))
+
;;; Do IR1 optimizations on a COMBINATION node.
(declaim (ftype (function (combination) (values)) ir1-optimize-combination))
(defun ir1-optimize-combination (node)
(when arg
(setf (lvar-reoptimize arg) nil)))
(when info
+ (check-important-result node info)
(let ((fun (fun-info-destroyed-constant-args info)))
(when fun
(let ((destroyed-constant-args (funcall fun args)))
(dolist (arg args)
(when arg
(setf (lvar-reoptimize arg) nil)))
-
+ (check-important-result node info)
(let ((fun (fun-info-destroyed-constant-args info)))
(when fun
(let ((destroyed-constant-args (funcall fun args)))
(let ((fun (fun-info-optimizer info)))
(unless (and fun (funcall fun node))
- (dolist (x (fun-info-transforms info))
- #!+sb-show
- (when *show-transforms-p*
- (let* ((lvar (basic-combination-fun node))
- (fname (lvar-fun-name lvar t)))
- (/show "trying transform" x (transform-function x) "for" fname)))
- (unless (ir1-transform node x)
- #!+sb-show
- (when *show-transforms-p*
- (/show "quitting because IR1-TRANSFORM result was NIL"))
- (return))))))))
+ ;; First give the VM a peek at the call
+ (multiple-value-bind (style transform)
+ (combination-implementation-style node)
+ (ecase style
+ (:direct
+ ;; The VM knows how to handle this.
+ )
+ (:transform
+ ;; The VM mostly knows how to handle this. We need
+ ;; to massage the call slightly, though.
+ (transform-call node transform (combination-fun-source-name node)))
+ (:default
+ ;; Let transforms have a crack at it.
+ (dolist (x (fun-info-transforms info))
+ #!+sb-show
+ (when *show-transforms-p*
+ (let* ((lvar (basic-combination-fun node))
+ (fname (lvar-fun-name lvar t)))
+ (/show "trying transform" x (transform-function x) "for" fname)))
+ (unless (ir1-transform node x)
+ #!+sb-show
+ (when *show-transforms-p*
+ (/show "quitting because IR1-TRANSFORM result was NIL"))
+ (return)))))))))))
(values))
(eq (combination-kind set-use) :known)
(fun-info-p (combination-fun-info set-use))
(not (node-to-be-deleted-p set-use))
- (eq (combination-fun-source-name set-use) '+))
- :exit-if-null)
+ (or (eq (combination-fun-source-name set-use) '+)
+ (eq (combination-fun-source-name set-use) '-)))
+ :exit-if-null)
+ (minusp (eq (combination-fun-source-name set-use) '-))
(+-args (basic-combination-args set-use))
(() (and (proper-list-of-length-p +-args 2 2)
(let ((first (principal-lvar-use
(first +-args))))
(and (ref-p first)
(eq (ref-leaf first) var))))
- :exit-if-null)
+ :exit-if-null)
(step-type (lvar-type (second +-args)))
(set-type (lvar-type (set-value set))))
(when (and (numeric-type-p initial-type)
(numeric-type-p step-type)
- (numeric-type-equal initial-type step-type))
+ (or (numeric-type-equal initial-type step-type)
+ ;; Detect cases like (LOOP FOR 1.0 to 5.0 ...), where
+ ;; the initial and the step are of different types,
+ ;; and the step is less contagious.
+ (numeric-type-equal initial-type
+ (numeric-contagion initial-type
+ step-type))))
(labels ((leftmost (x y cmp cmp=)
(cond ((eq x nil) nil)
((eq y nil) nil)
(t (if (funcall cmp x y) x y))))
(max* (x y) (leftmost x y #'> #'>=))
(min* (x y) (leftmost x y #'< #'<=)))
- (declare (inline compare))
(multiple-value-bind (low high)
- (cond ((csubtypep step-type (specifier-type '(real 0 *)))
- (values (numeric-type-low initial-type)
- (when (and (numeric-type-p set-type)
- (numeric-type-equal set-type initial-type))
- (max* (numeric-type-high initial-type)
- (numeric-type-high set-type)))))
- ((csubtypep step-type (specifier-type '(real * 0)))
- (values (when (and (numeric-type-p set-type)
- (numeric-type-equal set-type initial-type))
- (min* (numeric-type-low initial-type)
- (numeric-type-low set-type)))
- (numeric-type-high initial-type)))
- (t
- (values nil nil)))
+ (let ((step-type-non-negative (csubtypep step-type (specifier-type
+ '(real 0 *))))
+ (step-type-non-positive (csubtypep step-type (specifier-type
+ '(real * 0)))))
+ (cond ((or (and step-type-non-negative (not minusp))
+ (and step-type-non-positive minusp))
+ (values (numeric-type-low initial-type)
+ (when (and (numeric-type-p set-type)
+ (numeric-type-equal set-type initial-type))
+ (max* (numeric-type-high initial-type)
+ (numeric-type-high set-type)))))
+ ((or (and step-type-non-positive (not minusp))
+ (and step-type-non-negative minusp))
+ (values (when (and (numeric-type-p set-type)
+ (numeric-type-equal set-type initial-type))
+ (min* (numeric-type-low initial-type)
+ (numeric-type-low set-type)))
+ (numeric-type-high initial-type)))
+ (t
+ (values nil nil))))
(modified-numeric-type initial-type
:low low
:high high
(unless do-not-optimize
(setf (node-reoptimize cast) nil)))
+
+(deftransform make-symbol ((string) (simple-string))
+ `(%make-symbol string))
projects / sbcl.git / blobdiff