use))))
(plu lvar)))
+(defun principal-lvar-dest (lvar)
+ (labels ((pld (lvar)
+ (declare (type lvar lvar))
+ (let ((dest (lvar-dest lvar)))
+ (if (cast-p dest)
+ (pld (cast-lvar dest))
+ dest))))
+ (pld lvar)))
+
;;; Update lvar use information so that NODE is no longer a use of its
;;; LVAR.
;;;
(when (lambda-p clambda1)
(dolist (var (lambda-vars clambda1) t)
(dolist (var-ref (lambda-var-refs var))
- (let ((dest (lvar-dest (ref-lvar var-ref))))
+ (let ((dest (principal-lvar-dest (ref-lvar var-ref))))
(unless (and (combination-p dest) (recurse dest))
(return-from combination-args-flow-cleanly-p nil)))))))))))
(recurse combination1)))
(defun source-path-forms (path)
(subseq path 0 (position 'original-source-start path)))
+(defun tree-some (predicate tree)
+ (let ((seen (make-hash-table)))
+ (labels ((walk (tree)
+ (cond ((funcall predicate tree))
+ ((and (consp tree)
+ (not (gethash tree seen)))
+ (setf (gethash tree seen) t)
+ (or (walk (car tree))
+ (walk (cdr tree)))))))
+ (walk tree))))
+
;;; Return the innermost source form for NODE.
(defun node-source-form (node)
(declare (type node node))
(let* ((path (node-source-path node))
- (forms (source-path-forms path)))
+ (forms (remove-if (lambda (x)
+ (tree-some #'leaf-p x))
+ (source-path-forms path))))
+ ;; another option: if first form includes a leaf, return
+ ;; find-original-source instead.
(if forms
(first forms)
(values (find-original-source path)))))
(reoptimize-lvar prev)))
\f
;;; Return a new LEXENV just like DEFAULT except for the specified
-;;; slot values. Values for the alist slots are NCONCed to the
+;;; slot values. Values for the alist slots are APPENDed to the
;;; beginning of the current value, rather than replacing it entirely.
(defun make-lexenv (&key (default *lexenv*)
funs vars blocks tags
(macrolet ((frob (var slot)
`(let ((old (,slot default)))
(if ,var
- (nconc ,var old)
+ (append ,var old)
old))))
(internal-make-lexenv
(frob funs lexenv-funs)
(and ok (member name fun-names :test #'eq))))
(or (not arg-count)
(= arg-count (length (combination-args use)))))))
+
+;;; True if the optional has a rest-argument.
+(defun optional-rest-p (opt)
+ (dolist (var (optional-dispatch-arglist opt) nil)
+ (let* ((info (when (lambda-var-p var)
+ (lambda-var-arg-info var)))
+ (kind (when info
+ (arg-info-kind info))))
+ (when (eq :rest kind)
+ (return t)))))
+
+;;; Don't substitute single-ref variables on high-debug / low speed, to
+;;; improve the debugging experience. ...but don't bother keeping those
+;;; from system lambdas.
+(defun preserve-single-use-debug-var-p (call var)
+ (and (policy call (eql preserve-single-use-debug-variables 3))
+ (or (not (lambda-var-p var))
+ (not (lambda-system-lambda-p (lambda-var-home var))))))