;; function arguments. -- WHN 19990918
(not (ir1-attributep attr call))
(every #'constant-lvar-p args)
- (node-lvar node)
- ;; Even if the function is foldable in principle,
- ;; it might be one of our low-level
- ;; implementation-specific functions. Such
- ;; functions don't necessarily exist at runtime on
- ;; a plain vanilla ANSI Common Lisp
- ;; cross-compilation host, in which case the
- ;; cross-compiler can't fold it because the
- ;; cross-compiler doesn't know how to evaluate it.
- #+sb-xc-host
- (or (fboundp (combination-fun-source-name node))
- (progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%"
- (combination-fun-source-name node)
- (mapcar #'lvar-value args))
- nil)))
+ (node-lvar node))
(constant-fold-call node)
(return-from ir1-optimize-combination)))
(block-next (node-block call)))
(let ((new-fun (ir1-convert-inline-lambda
res
- :debug-name (debug-namify "LAMBDA-inlined "
- source-name
- "<unknown function>")))
+ :debug-name (debug-name 'lambda-inlined source-name)))
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
;; COMPILER-WARNING (and thus return FAILURE-P=T
;; from COMPILE-FILE) for legal code, so we we
;; use a wimpier COMPILE-STYLE-WARNING instead.
- #'compiler-style-warn
+ #-sb-xc-host #'compiler-style-warn
+ ;; On the other hand, for code we control, we
+ ;; should be able to work around any bug
+ ;; 173-related problems, and in particular we
+ ;; want to be alerted to calls to our own
+ ;; functions which aren't being folded away; a
+ ;; COMPILER-WARNING is butch enough to stop the
+ ;; SBCL build itself in its tracks.
+ #+sb-xc-host #'compiler-warn
"constant folding")
(cond ((not win)
(setf (combination-kind call) :error))
(when (and (numeric-type-p initial-type)
(numeric-type-p step-type)
(numeric-type-equal initial-type step-type))
- (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))
- (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))
- (numeric-type-low set-type))
- (numeric-type-high initial-type)))
- (t
- (values nil nil)))
- (modified-numeric-type initial-type
- :low low
- :high high
- :enumerable nil)))))
+ (labels ((leftmost (x y cmp cmp=)
+ (cond ((eq x nil) nil)
+ ((eq y nil) nil)
+ ((listp x)
+ (let ((x1 (first x)))
+ (cond ((listp y)
+ (let ((y1 (first y)))
+ (if (funcall cmp x1 y1) x y)))
+ (t
+ (if (funcall cmp x1 y) x y)))))
+ ((listp y)
+ (let ((y1 (first y)))
+ (if (funcall cmp= x y1) x y)))
+ (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)))
+ (modified-numeric-type initial-type
+ :low low
+ :high high
+ :enumerable nil))))))
(deftransform + ((x y) * * :result result)
"check for iteration variable reoptimization"
(let ((dest (principal-lvar-end result))