(defun %continuation-%externally-checkable-type (cont)
(declare (type continuation cont))
(let ((dest (continuation-dest cont)))
- (if (not (and dest (combination-p dest)))
- ;; TODO: MV-COMBINATION
- (setf (continuation-%externally-checkable-type cont) *wild-type*)
- (let* ((fun (combination-fun dest))
- (args (combination-args dest))
- (fun-type (continuation-type fun)))
- (setf (continuation-%externally-checkable-type fun) *wild-type*)
- (if (or (not (fun-type-p fun-type))
- ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
- (fun-type-wild-args fun-type))
- (progn (dolist (arg args)
- (when arg
- (setf (continuation-%externally-checkable-type arg)
- *wild-type*)))
- *wild-type*)
- (let* ((arg-types (append (fun-type-required fun-type)
- (fun-type-optional fun-type)
- (let ((rest (list (or (fun-type-rest fun-type)
- *wild-type*))))
- (setf (cdr rest) rest)))))
- ;; TODO: &KEY
- (loop
- for arg of-type continuation in args
- and type of-type ctype in arg-types
- do (when arg
- (setf (continuation-%externally-checkable-type arg)
- (coerce-to-values type))))
- (continuation-%externally-checkable-type cont)))))))
+ (if (not (and dest
+ (combination-p dest)))
+ ;; TODO: MV-COMBINATION
+ (setf (continuation-%externally-checkable-type cont) *wild-type*)
+ (let* ((fun (combination-fun dest))
+ (args (combination-args dest))
+ (fun-type (continuation-type fun)))
+ (setf (continuation-%externally-checkable-type fun) *wild-type*)
+ (if (or (not (call-full-like-p dest))
+ (not (fun-type-p fun-type))
+ ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
+ (fun-type-wild-args fun-type))
+ (dolist (arg args)
+ (when arg
+ (setf (continuation-%externally-checkable-type arg)
+ *wild-type*)))
+ (map-combination-args-and-types
+ (lambda (arg type)
+ (setf (continuation-%externally-checkable-type arg)
+ (acond ((continuation-%externally-checkable-type arg)
+ (values-type-intersection
+ it (coerce-to-values type)))
+ (t (coerce-to-values type)))))
+ dest)))))
+ (continuation-%externally-checkable-type cont))
(declaim (inline flush-continuation-externally-checkable-type))
(defun flush-continuation-externally-checkable-type (cont)
(declare (type continuation cont))
(reoptimize-continuation cont)
checked-value)))))
-;;; Assert that CALL is to a function of the specified TYPE. It is
-;;; assumed that the call is legal and has only constants in the
-;;; keyword positions.
-(defun assert-call-type (call type)
- (declare (type combination call) (type fun-type type))
- (derive-node-type call (fun-type-returns type))
- (let ((args (combination-args call))
- (policy (lexenv-policy (node-lexenv call))))
- (dolist (req (fun-type-required type))
- (when (null args) (return-from assert-call-type))
- (let ((arg (pop args)))
- (assert-continuation-type arg req policy)))
- (dolist (opt (fun-type-optional type))
- (when (null args) (return-from assert-call-type))
- (let ((arg (pop args)))
- (assert-continuation-type arg opt policy)))
-
- (let ((rest (fun-type-rest type)))
- (when rest
- (dolist (arg args)
- (assert-continuation-type arg rest policy))))
-
- (dolist (key (fun-type-keywords type))
- (let ((name (key-info-name key)))
- (do ((arg args (cddr arg)))
- ((null arg))
- (when (eq (continuation-value (first arg)) name)
- (assert-continuation-type
- (second arg) (key-info-type key)
- policy))))))
- (values))
\f
;;;; IR1-OPTIMIZE
;; cross-compiler can't fold it because the
;; cross-compiler doesn't know how to evaluate it.
#+sb-xc-host
- (fboundp (combination-fun-source-name node)))
+ (or (fboundp (combination-fun-source-name node))
+ (progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%"
+ (combination-fun-source-name node)
+ (mapcar #'continuation-value args))
+ nil)))
(constant-fold-call node)
(return-from ir1-optimize-combination)))
(reoptimize-continuation cont))))))
(values))))
+;;; Iteration variable: exactly one SETQ of the form:
+;;;
+;;; (let ((var initial))
+;;; ...
+;;; (setq var (+ var step))
+;;; ...)
+(defun maybe-infer-iteration-var-type (var initial-type)
+ (binding* ((sets (lambda-var-sets var) :exit-if-null)
+ (set (first sets))
+ (() (null (rest sets)) :exit-if-null)
+ (set-use (principal-continuation-use (set-value set)))
+ (() (and (combination-p set-use)
+ (fun-info-p (combination-kind set-use))
+ (eq (combination-fun-source-name set-use) '+))
+ :exit-if-null)
+ (+-args (basic-combination-args set-use))
+ (() (and (proper-list-of-length-p +-args 2 2)
+ (let ((first (principal-continuation-use
+ (first +-args))))
+ (and (ref-p first)
+ (eq (ref-leaf first) var))))
+ :exit-if-null)
+ (step-type (continuation-type (second +-args)))
+ (set-type (continuation-type (set-value set))))
+ (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)))))
+(deftransform + ((x y) * * :result result)
+ "check for iteration variable reoptimization"
+ (let ((dest (principal-continuation-end result))
+ (use (principal-continuation-use x)))
+ (when (and (ref-p use)
+ (set-p dest)
+ (eq (ref-leaf use)
+ (set-var dest)))
+ (reoptimize-continuation (set-value dest))))
+ (give-up-ir1-transform))
+
;;; Figure out the type of a LET variable that has sets. We compute
-;;; the union of the initial value TYPE and the types of all the set
+;;; the union of the INITIAL-TYPE and the types of all the set
;;; values and to a PROPAGATE-TO-REFS with this type.
-(defun propagate-from-sets (var type)
- (collect ((res type type-union))
+(defun propagate-from-sets (var initial-type)
+ (collect ((res initial-type type-union))
(dolist (set (basic-var-sets var))
(let ((type (continuation-type (set-value set))))
(res type)
(when (node-reoptimize set)
(derive-node-type set (make-single-value-type type))
(setf (node-reoptimize set) nil))))
- (propagate-to-refs var (res)))
+ (let ((res (res)))
+ (awhen (maybe-infer-iteration-var-type var initial-type)
+ (setq res it))
+ (propagate-to-refs var res)))
(values))
;;; If a LET variable, find the initial value's type and do
(when (and (lambda-var-p var) (leaf-refs var))
(let ((home (lambda-var-home var)))
(when (eq (functional-kind home) :let)
- (let ((iv (let-var-initial-value var)))
- (setf (continuation-reoptimize iv) nil)
- (propagate-from-sets var (continuation-type iv)))))))
+ (let* ((initial-value (let-var-initial-value var))
+ (initial-type (continuation-type initial-value)))
+ (setf (continuation-reoptimize initial-value) nil)
+ (propagate-from-sets var initial-type))))))
(derive-node-type node (make-single-value-type
(continuation-type (set-value node))))
projects / sbcl.git / blobdiff