(when value
(derive-node-type node (lvar-derived-type value)))))
(cset
+ ;; PROPAGATE-FROM-SETS can do a better job if NODE-REOPTIMIZE
+ ;; is accurate till the node actually has been reoptimized.
+ (setf (node-reoptimize node) t)
(ir1-optimize-set node))
(cast
(ir1-optimize-cast node)))))
(values))
+(defun xep-tail-combination-p (node)
+ (and (combination-p node)
+ (let* ((lvar (combination-lvar node))
+ (dest (when (lvar-p lvar) (lvar-dest lvar)))
+ (lambda (when (return-p dest) (return-lambda dest))))
+ (and (lambda-p lambda)
+ (eq :external (lambda-kind lambda))))))
+
;;; If NODE doesn't return (i.e. return type is NIL), then terminate
;;; the block there, and link it to the component tail.
;;;
(declare (ignore lvar))
(unless (or (and (eq node (block-last block)) (eq succ tail))
(block-delete-p block))
- (when (eq (node-derived-type node) *empty-type*)
+ ;; Even if the combination will never return, don't terminate if this
+ ;; is the tail call of a XEP: doing that would inhibit TCO.
+ (when (and (eq (node-derived-type node) *empty-type*)
+ (not (xep-tail-combination-p node)))
(cond (ir1-converting-not-optimizing-p
(cond
((block-last block)
((nil :maybe-inline) (policy call (zerop space))))
(defined-fun-p leaf)
(defined-fun-inline-expansion leaf)
- (let ((fun (defined-fun-functional leaf)))
- (or (not fun)
- (and (eq inlinep :inline) (functional-kind fun))))
(inline-expansion-ok call))
- (flet (;; FIXME: Is this what the old CMU CL internal documentation
- ;; called semi-inlining? A more descriptive name would
- ;; be nice. -- WHN 2002-01-07
- (frob ()
+ ;; Inline: if the function has already been converted at another call
+ ;; site in this component, we point this REF to the functional. If not,
+ ;; we convert the expansion.
+ ;;
+ ;; For :INLINE case local call analysis will copy the expansion later,
+ ;; but for :MAYBE-INLINE and NIL cases we only get one copy of the
+ ;; expansion per component.
+ ;;
+ ;; FIXME: We also convert in :INLINE & FUNCTIONAL-KIND case below. What
+ ;; is it for?
+ (flet ((frob ()
(let* ((name (leaf-source-name leaf))
(res (ir1-convert-inline-expansion
name
leaf
inlinep
(info :function :info name))))
- ;; allow backward references to this function from
- ;; following top level forms
- (setf (defined-fun-functional leaf) res)
+ ;; Allow backward references to this function from following
+ ;; forms. (Reused only if policy matches.)
+ (push res (defined-fun-functionals leaf))
(change-ref-leaf ref res))))
- (if ir1-converting-not-optimizing-p
- (frob)
- (with-ir1-environment-from-node call
- (frob)
- (locall-analyze-component *current-component*))))
-
- (values (ref-leaf (lvar-uses (basic-combination-fun call)))
- nil))
+ (let ((fun (defined-fun-functional leaf)))
+ (if (or (not fun)
+ (and (eq inlinep :inline) (functional-kind fun)))
+ ;; Convert.
+ (if ir1-converting-not-optimizing-p
+ (frob)
+ (with-ir1-environment-from-node call
+ (frob)
+ (locall-analyze-component *current-component*)))
+ ;; If we've already converted, change ref to the converted
+ ;; functional.
+ (change-ref-leaf ref fun))))
+ (values (ref-leaf ref) nil))
(t
(let ((info (info :function :info (leaf-source-name leaf))))
(if info
;;; syntax check, arg/result type processing, but still call
;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda,
;;; and that checking is done by local call analysis.
-(defun validate-call-type (call type ir1-converting-not-optimizing-p)
+(defun validate-call-type (call type defined-type ir1-converting-not-optimizing-p)
(declare (type combination call) (type ctype type))
(cond ((not (fun-type-p type))
(aver (multiple-value-bind (val win)
(csubtypep type (specifier-type 'function))
(or val (not win))))
+ ;; In the commonish case where the function has been defined
+ ;; in another file, we only get FUNCTION for the type; but we
+ ;; can check whether the current call is valid for the
+ ;; existing definition, even if only to STYLE-WARN about it.
+ (when defined-type
+ (valid-fun-use call defined-type
+ :argument-test #'always-subtypep
+ :result-test nil
+ :lossage-fun #'compiler-style-warn
+ :unwinnage-fun #'compiler-notify))
(recognize-known-call call ir1-converting-not-optimizing-p))
((valid-fun-use call type
:argument-test #'always-subtypep
(derive-node-type call (tail-set-type (lambda-tail-set fun))))))
(:full
(multiple-value-bind (leaf info)
- (validate-call-type call (lvar-type fun-lvar) nil)
+ (validate-call-type call (lvar-type fun-lvar) nil nil)
(cond ((functional-p leaf)
(convert-call-if-possible
(lvar-uses (basic-combination-fun call))
(let ((int (type-approx-intersection2 var-type type)))
(when (type/= int var-type)
(setf (leaf-type leaf) int)
- (dolist (ref (leaf-refs leaf))
- (derive-node-type ref (make-single-value-type int))
- ;; KLUDGE: LET var substitution
- (let* ((lvar (node-lvar ref)))
- (when (and lvar (combination-p (lvar-dest lvar)))
- (reoptimize-lvar lvar))))))
+ (let ((s-int (make-single-value-type int)))
+ (dolist (ref (leaf-refs leaf))
+ (derive-node-type ref s-int)
+ ;; KLUDGE: LET var substitution
+ (let* ((lvar (node-lvar ref)))
+ (when (and lvar (combination-p (lvar-dest lvar)))
+ (reoptimize-lvar lvar)))))))
(values))))
;;; Iteration variable: exactly one SETQ of the form:
;;; 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 initial-type)
- (collect ((res initial-type type-union))
- (dolist (set (basic-var-sets var))
+ (let ((changes (not (csubtypep (lambda-var-last-initial-type var) initial-type)))
+ (types nil))
+ (dolist (set (lambda-var-sets var))
(let ((type (lvar-type (set-value set))))
- (res type)
+ (push type types)
(when (node-reoptimize set)
- (derive-node-type set (make-single-value-type type))
+ (let ((old-type (node-derived-type set)))
+ (unless (values-subtypep old-type type)
+ (derive-node-type set (make-single-value-type type))
+ (setf changes t)))
(setf (node-reoptimize set) nil))))
- (let ((res (res)))
- (awhen (maybe-infer-iteration-var-type var initial-type)
- (setq res it))
- (propagate-to-refs var res)))
+ (when changes
+ (setf (lambda-var-last-initial-type var) initial-type)
+ (let ((res-type (or (maybe-infer-iteration-var-type var initial-type)
+ (apply #'type-union initial-type types))))
+ (propagate-to-refs var res-type))))
(values))
;;; If a LET variable, find the initial value's type and do
(initial-type (lvar-type initial-value)))
(setf (lvar-reoptimize initial-value) nil)
(propagate-from-sets var initial-type))))))
-
(derive-node-type node (make-single-value-type
(lvar-type (set-value node))))
+ (setf (node-reoptimize node) nil)
(values))
;;; Return true if the value of REF will always be the same (and is
projects / sbcl.git / blobdiff