X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=2067422c70aa90e5fafb01b69573fe021b882d9d;hb=37da4165c0e4af1aa559762ea8b65ae061cd310f;hp=33a8d3d872505427b8abcb7e10b9cf9f65f5f020;hpb=966eb48ee8076f0f3050063d3b9ebee5bbee7dc7;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 33a8d3d..2067422 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -80,6 +80,15 @@ 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. ;;; @@ -456,16 +465,39 @@ ;;;; DYNAMIC-EXTENT related +(defun lambda-var-original-name (leaf) + (let ((home (lambda-var-home leaf))) + (if (eq :external (functional-kind home)) + (let* ((entry (functional-entry-fun home)) + (p (1- (position leaf (lambda-vars home))))) + (leaf-debug-name + (if (optional-dispatch-p entry) + (elt (optional-dispatch-arglist entry) p) + (elt (lambda-vars entry) p)))) + (leaf-debug-name leaf)))) + (defun note-no-stack-allocation (lvar &key flush) (do-uses (use (principal-lvar lvar)) (unless (or ;; Don't complain about not being able to stack allocate constants. (and (ref-p use) (constant-p (ref-leaf use))) ;; If we're flushing, don't complain if we can flush the combination. - (and flush (combination-p use) (flushable-combination-p use))) + (and flush (combination-p use) (flushable-combination-p use)) + ;; Don't report those with homes in :OPTIONAL -- we'd get doubled + ;; reports that way. + (and (ref-p use) (lambda-var-p (ref-leaf use)) + (eq :optional (lambda-kind (lambda-var-home (ref-leaf use)))))) + ;; FIXME: For the first leg (lambda-bind (lambda-var-home ...)) + ;; would be a far better description, but since we use + ;; *COMPILER-ERROR-CONTEXT* for muffling we can't -- as that node + ;; can have different handled conditions. (let ((*compiler-error-context* use)) - (compiler-notify "could not stack allocate the result of ~S" - (find-original-source (node-source-path use))))))) + (if (and (ref-p use) (lambda-var-p (ref-leaf use))) + (compiler-notify "~@" + (lambda-var-original-name (ref-leaf use)) + (find-original-source (node-source-path use))) + (compiler-notify "~@" + (find-original-source (node-source-path use)))))))) (defun use-good-for-dx-p (use dx &optional component) ;; FIXME: Can casts point to LVARs in other components? @@ -537,11 +569,22 @@ (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 ref-good-for-dx-p (ref) + (let* ((lvar (ref-lvar ref)) + (dest (when lvar (lvar-dest lvar)))) + (and (combination-p dest) + (eq :known (combination-kind dest)) + (awhen (combination-fun-info dest) + (or (ir1-attributep (fun-info-attributes it) dx-safe) + (and (not (combination-lvar dest)) + (awhen (fun-info-result-arg it) + (eql lvar (nth it (combination-args dest)))))))))) + (defun trivial-lambda-var-ref-p (use) (and (ref-p use) (let ((var (ref-leaf use))) @@ -550,9 +593,13 @@ (neq :indefinite (lambda-var-extent var))) (let ((home (lambda-var-home var)) (refs (lambda-var-refs var))) - ;; bound by a system lambda, no other REFS + ;; bound by a non-XEP system lambda, no other REFS that aren't + ;; DX-SAFE, or are result-args when the result is discarded. (when (and (lambda-system-lambda-p home) - (eq use (car refs)) (not (cdr refs))) + (neq :external (lambda-kind home)) + (dolist (ref refs t) + (unless (or (eq use ref) (ref-good-for-dx-p ref)) + (return nil)))) ;; the LAMBDA this var is bound by has only a single REF, going ;; to a combination (let* ((lambda-refs (lambda-refs home)) @@ -563,16 +610,15 @@ (defun trivial-lambda-var-ref-lvar (use) (let* ((this (ref-leaf use)) - (home (lambda-var-home this))) - (multiple-value-bind (fun vars) - (values home (lambda-vars home)) - (let* ((combination (lvar-dest (ref-lvar (car (lambda-refs fun))))) - (args (combination-args combination))) - (assert (= (length vars) (length args))) - (loop for var in vars - for arg in args - when (eq var this) - return arg))))) + (fun (lambda-var-home this)) + (vars (lambda-vars fun)) + (combination (lvar-dest (ref-lvar (car (lambda-refs fun))))) + (args (combination-args combination))) + (aver (= (length vars) (length args))) + (loop for var in vars + for arg in args + when (eq var this) + return arg))) ;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends. (defun handle-nested-dynamic-extent-lvars (dx lvar &optional recheck-component) @@ -800,7 +846,7 @@ (reoptimize-lvar prev))) ;;; 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 @@ -815,7 +861,7 @@ (macrolet ((frob (var slot) `(let ((old (,slot default))) (if ,var - (nconc ,var old) + (append ,var old) old)))) (internal-make-lexenv (frob funs lexenv-funs) @@ -2259,3 +2305,21 @@ is :ANY, the function name is not checked." (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))))))