;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
;;; error for CONT's value not to be TYPEP to TYPE. We implement it
-;;; moving uses behind a new CAST node. If we improve the assertion,
+;;; splitting off DEST a new CAST node. If we improve the assertion,
;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new
-;;; assertion will be checked.
+;;; assertion will be checked. We return the new "argument"
+;;; continuation of DEST.
(defun assert-continuation-type (cont type policy)
(declare (type continuation cont) (type ctype type))
- (when (values-subtypep (continuation-derived-type cont) type)
- (return-from assert-continuation-type))
- (let* ((dest (continuation-dest cont))
- (prev-cont (node-prev dest)))
- (aver dest)
- (with-ir1-environment-from-node dest
- (let* ((cast (make-cast cont type policy))
- (checked-value (make-continuation)))
- (setf (continuation-next prev-cont) cast
- (node-prev cast) prev-cont)
- (use-continuation cast checked-value)
- (link-node-to-previous-continuation dest checked-value)
- (substitute-continuation checked-value cont)
- (setf (continuation-dest cont) cast)
- (reoptimize-continuation cont)))))
+ (if (values-subtypep (continuation-derived-type cont) type)
+ cont
+ (let* ((dest (continuation-dest cont))
+ (prev-cont (node-prev dest)))
+ (aver dest)
+ (with-ir1-environment-from-node dest
+ (let* ((cast (make-cast cont type policy))
+ (checked-value (make-continuation)))
+ (setf (continuation-next prev-cont) cast
+ (node-prev cast) prev-cont)
+ (use-continuation cast checked-value)
+ (link-node-to-previous-continuation dest checked-value)
+ (substitute-continuation checked-value cont)
+ (setf (continuation-dest cont) cast)
+ (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
(join-blocks block next))
t)
((and (null (block-start-uses next))
- (not (exit-p (continuation-dest last-cont)))
+ (not (typep (continuation-dest last-cont)
+ '(or exit creturn)))
(null (continuation-lexenv-uses last-cont)))
(assert (null (find-uses next-cont)))
(when (continuation-dest last-cont)
;; 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)))
;;; the NODE's CONT to be a dummy continuation to prevent the use from
;;; confusing things.
;;;
-;;; Except when called during IR1 [FIXME: What does this mean? Except
-;;; during IR1 conversion? What about IR1 optimization?], we delete
-;;; the continuation if it has no other uses. (If it does have other
-;;; uses, we reoptimize.)
+;;; Except when called during IR1 convertion, we delete the
+;;; continuation if it has no other uses. (If it does have other uses,
+;;; we reoptimize.)
;;;
;;; Termination on the basis of a continuation type is
;;; inhibited when:
;;; -- The continuation is deleted (hence the assertion is spurious), or
;;; -- We are in IR1 conversion (where THE assertions are subject to
-;;; weakening.)
+;;; weakening.) FIXME: Now THE assertions are not weakened, but new
+;;; uses can(?) be added later. -- APD, 2003-07-17
(defun maybe-terminate-block (node ir1-converting-not-optimizing-p)
(declare (type (or basic-combination cast) node))
(let* ((block (node-block node))
;;;
;;; We return the leaf referenced (NIL if not a leaf) and the
;;; FUN-INFO assigned.
-;;;
-;;; FIXME: The IR1-CONVERTING-NOT-OPTIMIZING-P argument is what the
-;;; old CMU CL code called IR1-P, without explanation. My (WHN
-;;; 2002-01-09) tentative understanding of it is that we can call this
-;;; operation either in initial IR1 conversion or in later IR1
-;;; optimization, and it tells which is which. But it would be good
-;;; for someone who really understands it to check whether this is
-;;; really right.
(defun recognize-known-call (call ir1-converting-not-optimizing-p)
(declare (type combination call))
(let* ((ref (continuation-use (basic-combination-fun call)))
;; issue a full WARNING if the call
;; violates a DECLAIM FTYPE.
:lossage-fun #'compiler-style-warn
- :unwinnage-fun #'compiler-note)
+ :unwinnage-fun #'compiler-notify)
(assert-call-type call type)
(maybe-terminate-block call ir1-converting-not-optimizing-p)
(recognize-known-call call ir1-converting-not-optimizing-p))
(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))))
+ (when (and (numeric-type-p initial-type)
+ (numeric-type-p step-type)
+ (eq (numeric-type-class initial-type)
+ (numeric-type-class step-type))
+ (eq (numeric-type-format initial-type)
+ (numeric-type-format step-type))
+ (eq (numeric-type-complexp initial-type)
+ (numeric-type-complexp step-type)))
+ (multiple-value-bind (low high)
+ (cond ((csubtypep step-type (specifier-type '(real 0 *)))
+ (values (numeric-type-low initial-type) nil))
+ ((csubtypep step-type (specifier-type '(real * 0)))
+ (values nil (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 (type-intersection 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))))
;;; vars.
(defun ir1-optimize-mv-bind (node)
(declare (type mv-combination node))
- (let ((arg (first (basic-combination-args node)))
- (vars (lambda-vars (combination-lambda node))))
- (multiple-value-bind (types nvals)
- (values-types (continuation-derived-type arg))
- (unless (eq nvals :unknown)
- (mapc (lambda (var type)
- (if (basic-var-sets var)
- (propagate-from-sets var type)
- (propagate-to-refs var type)))
- vars
- (adjust-list types
- (length vars)
- (specifier-type 'null)))))
+ (let* ((arg (first (basic-combination-args node)))
+ (vars (lambda-vars (combination-lambda node)))
+ (n-vars (length vars))
+ (types (values-type-in (continuation-derived-type arg)
+ n-vars)))
+ (loop for var in vars
+ and type in types
+ do (if (basic-var-sets var)
+ (propagate-from-sets var type)
+ (propagate-to-refs var type)))
(setf (continuation-reoptimize arg) nil))
(values))
(unless (continuation-single-value-p (node-cont node))
(give-up-ir1-transform))
(setf (node-derived-type node) *wild-type*)
+ (principal-continuation-single-valuify (node-cont node))
(if vals
(let ((dummies (make-gensym-list (length (cdr vals)))))
`(lambda (val ,@dummies)
(declare (type cast cast))
(let* ((value (cast-value cast))
(value-type (continuation-derived-type value))
+ (cont (node-cont cast))
+ (dest (continuation-dest cont))
(atype (cast-asserted-type cast))
(int (values-type-intersection value-type atype)))
(derive-node-type cast int)
value
;; FIXME: Derived type.
`(%compile-time-type-error 'dummy
- ',(type-specifier (coerce-to-values atype))
+ ',(type-specifier atype)
',(type-specifier value-type)))
;; KLUDGE: FILTER-CONTINUATION does not work for
;; non-returning functions, so we declare the return type of
(when (eq (node-derived-type cast) *empty-type*)
(maybe-terminate-block cast nil))
- (flet ((delete-cast ()
- (let ((cont (node-cont cast)))
- (delete-filter cast cont value)
- (reoptimize-continuation cont)
- (when (continuation-single-value-p cont)
- (note-single-valuified-continuation cont))
- (when (not (continuation-dest cont))
- (reoptimize-continuation-uses cont)))))
- (cond
- ((and (not do-not-optimize)
- (values-subtypep value-type
- (cast-asserted-type cast)))
- (delete-cast)
- (return-from ir1-optimize-cast t))
- ((and (cast-%type-check cast)
- (values-subtypep value-type
- (cast-type-to-check cast)))
- (setf (cast-%type-check cast) nil)))))
+ (when (and (not do-not-optimize)
+ (values-subtypep value-type
+ (cast-asserted-type cast)))
+ (delete-filter cast cont value)
+ (reoptimize-continuation cont)
+ (when (continuation-single-value-p cont)
+ (note-single-valuified-continuation cont))
+ (when (not dest)
+ (reoptimize-continuation-uses cont))
+ (return-from ir1-optimize-cast t))
+
+ (when (and (not do-not-optimize)
+ (not (continuation-use value))
+ dest)
+ (collect ((merges))
+ (do-uses (use value)
+ (when (and (values-subtypep (node-derived-type use) atype)
+ (immediately-used-p value use))
+ (ensure-block-start cont)
+ (delete-continuation-use use)
+ (add-continuation-use use cont)
+ (unlink-blocks (node-block use) (node-block cast))
+ (link-blocks (node-block use) (continuation-block cont))
+ (when (and (return-p dest)
+ (basic-combination-p use)
+ (eq (basic-combination-kind use) :local))
+ (merges use))))
+ (dolist (use (merges))
+ (merge-tail-sets use))))
+
+ (when (and (cast-%type-check cast)
+ (values-subtypep value-type
+ (cast-type-to-check cast)))
+ (setf (cast-%type-check cast) nil)))
(unless do-not-optimize
(setf (node-reoptimize cast) nil)))
projects / sbcl.git / blobdiff