+;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
+;;; NIL, NIL.
+(defun lvar-source (lvar)
+ (let ((use (lvar-uses lvar)))
+ (if (listp use)
+ (values nil nil)
+ (values (node-source-form use) t))))
+
+;;; Return the unique node, delivering a value to LVAR.
+#!-sb-fluid (declaim (inline lvar-use))
+(defun lvar-use (lvar)
+ (the (not list) (lvar-uses lvar)))
+
+#!-sb-fluid (declaim (inline lvar-has-single-use-p))
+(defun lvar-has-single-use-p (lvar)
+ (typep (lvar-uses lvar) '(not list)))
+
+;;; Return the LAMBDA that is CTRAN's home, or NIL if there is none.
+(declaim (ftype (sfunction (ctran) (or clambda null))
+ ctran-home-lambda-or-null))
+(defun ctran-home-lambda-or-null (ctran)
+ ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
+ ;; implementation might not be quite right, or might be uglier than
+ ;; necessary. It appears that the original Python never found a need
+ ;; to do this operation. The obvious things based on
+ ;; NODE-HOME-LAMBDA of CTRAN-USE usually work; then if that fails,
+ ;; BLOCK-HOME-LAMBDA of CTRAN-BLOCK works, given that we
+ ;; generalize it enough to grovel harder when the simple CMU CL
+ ;; approach fails, and furthermore realize that in some exceptional
+ ;; cases it might return NIL. -- WHN 2001-12-04
+ (cond ((ctran-use ctran)
+ (node-home-lambda (ctran-use ctran)))
+ ((ctran-block ctran)
+ (block-home-lambda-or-null (ctran-block ctran)))
+ (t
+ (bug "confused about home lambda for ~S" ctran))))
+
+;;; Return the LAMBDA that is CTRAN's home.
+(declaim (ftype (sfunction (ctran) clambda) ctran-home-lambda))
+(defun ctran-home-lambda (ctran)
+ (ctran-home-lambda-or-null ctran))
+
+#!-sb-fluid (declaim (inline lvar-single-value-p))
+(defun lvar-single-value-p (lvar)
+ (or (not lvar)
+ (let ((dest (lvar-dest lvar)))
+ (typecase dest
+ ((or creturn exit)
+ nil)
+ (mv-combination
+ (eq (basic-combination-fun dest) lvar))
+ (cast
+ (locally
+ (declare (notinline lvar-single-value-p))
+ (and (not (values-type-p (cast-asserted-type dest)))
+ (lvar-single-value-p (node-lvar dest)))))
+ (t
+ t)))))
+
+(defun principal-lvar-end (lvar)
+ (loop for prev = lvar then (node-lvar dest)
+ for dest = (and prev (lvar-dest prev))
+ while (cast-p dest)
+ finally (return (values dest prev))))
+
+(defun principal-lvar-single-valuify (lvar)
+ (loop for prev = lvar then (node-lvar dest)
+ for dest = (and prev (lvar-dest prev))
+ while (cast-p dest)
+ do (setf (node-derived-type dest)
+ (make-short-values-type (list (single-value-type
+ (node-derived-type dest)))))
+ (reoptimize-lvar prev)))