X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=964a23f3e86b92e9de9ff39a09c319b35799d57e;hb=1e1ba5d5b43e20a4c0b157f08d4c85fe880c7e25;hp=aeb2566babd5b174adfe4742caa3bd2062d76453;hpb=c8ec5e9baf0e79e49aa54c6ac1b2582b74301d5b;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index aeb2566..964a23f 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -149,6 +149,16 @@ (t (eq (block-start (first (block-succ (node-block node)))) (node-prev dest)))))) +;;; Returns the defined (usually untrusted) type of the combination, +;;; or NIL if we couldn't figure it out. +(defun combination-defined-type (combination) + (let ((use (principal-lvar-use (basic-combination-fun combination)))) + (or (when (ref-p use) + (let ((type (leaf-defined-type (ref-leaf use)))) + (when (fun-type-p type) + (fun-type-returns type)))) + *wild-type*))) + ;;; Return true if LVAR destination is executed after node with only ;;; uninteresting nodes intervening. ;;; @@ -446,6 +456,14 @@ ;;;; DYNAMIC-EXTENT related +(defun lambda-var-original-name (leaf) + (let* ((home (lambda-var-home leaf))) + (if (eq :external (lambda-kind home)) + (let ((p (1- (position leaf (lambda-vars home))))) + (leaf-debug-name + (elt (lambda-vars (lambda-entry-fun home)) p))) + (leaf-debug-name leaf)))) + (defun note-no-stack-allocation (lvar &key flush) (do-uses (use (principal-lvar lvar)) (unless (or @@ -454,13 +472,13 @@ ;; If we're flushing, don't complain if we can flush the combination. (and flush (combination-p use) (flushable-combination-p use))) (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)))))))) -(declaim (ftype (sfunction (node (member nil t :truly) &optional (or null component)) - boolean) use-good-for-dx-p)) -(declaim (ftype (sfunction (lvar (member nil t :truly) &optional (or null component)) - boolean) lvar-good-for-dx-p)) (defun use-good-for-dx-p (use dx &optional component) ;; FIXME: Can casts point to LVARs in other components? ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the @@ -539,12 +557,14 @@ (defun trivial-lambda-var-ref-p (use) (and (ref-p use) (let ((var (ref-leaf use))) - ;; lambda-var, no SETS - (when (and (lambda-var-p var) (not (lambda-var-sets var))) + ;; lambda-var, no SETS, not explicitly indefinite-extent. + (when (and (lambda-var-p var) (not (lambda-var-sets var)) + (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 (when (and (lambda-system-lambda-p home) + (neq :external (lambda-kind home)) (eq use (car refs)) (not (cdr refs))) ;; the LAMBDA this var is bound by has only a single REF, going ;; to a combination @@ -556,16 +576,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) @@ -1259,11 +1278,32 @@ ;;; Return functional for DEFINED-FUN which has been converted in policy ;;; corresponding to the current one, or NIL if no such functional exists. +;;; +;;; Also check that the parent of the functional is visible in the current +;;; environment. (defun defined-fun-functional (defined-fun) - (let ((policy (lexenv-%policy *lexenv*))) - (dolist (functional (defined-fun-functionals defined-fun)) - (when (equal policy (lexenv-%policy (functional-lexenv functional))) - (return functional))))) + (let ((functionals (defined-fun-functionals defined-fun))) + (when functionals + (let* ((sample (car functionals)) + (there (lambda-parent (if (lambda-p sample) + sample + (optional-dispatch-main-entry sample))))) + (when there + (labels ((lookup (here) + (unless (eq here there) + (if here + (lookup (lambda-parent here)) + ;; We looked up all the way up, and didn't find the parent + ;; of the functional -- therefore it is nested in a lambda + ;; we don't see, so return nil. + (return-from defined-fun-functional nil))))) + (lookup (lexenv-lambda *lexenv*))))) + ;; Now find a functional whose policy matches the current one, if we already + ;; have one. + (let ((policy (lexenv-%policy *lexenv*))) + (dolist (functional functionals) + (when (equal policy (lexenv-%policy (functional-lexenv functional))) + (return functional))))))) ;;; Do stuff to delete the semantic attachments of a REF node. When ;;; this leaves zero or one reference, we do a type dispatch off of @@ -1284,7 +1324,8 @@ (aver (null (functional-entry-fun leaf))) (delete-lambda leaf)) (:external - (delete-lambda leaf)) + (unless (functional-has-external-references-p leaf) + (delete-lambda leaf))) ((:deleted :zombie :optional)))) (optional-dispatch (unless (eq (functional-kind leaf) :deleted) @@ -2188,17 +2229,35 @@ is :ANY, the function name is not checked." (setf (block-reoptimize (node-block node)) t) (reoptimize-component (node-component node) :maybe))))))) -;;; Return true if LVAR's only use is a non-NOTINLINE reference to a -;;; global function with one of the specified NAMES. +;;; Return true if LVAR's only use is a reference to a global function +;;; designator with one of the specified NAMES, that hasn't been +;;; declared NOTINLINE. (defun lvar-fun-is (lvar names) (declare (type lvar lvar) (list names)) (let ((use (lvar-uses lvar))) (and (ref-p use) - (let ((leaf (ref-leaf use))) - (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function) - (not (null (member (leaf-source-name leaf) names - :test #'equal)))))))) + (let* ((*lexenv* (node-lexenv use)) + (leaf (ref-leaf use)) + (name + (cond ((global-var-p leaf) + ;; Case 1: #'NAME + (and (eq (global-var-kind leaf) :global-function) + (car (member (leaf-source-name leaf) names + :test #'equal)))) + ((constant-p leaf) + (let ((value (constant-value leaf))) + (car (if (functionp value) + ;; Case 2: #.#'NAME + (member value names + :key (lambda (name) + (and (fboundp name) + (fdefinition name))) + :test #'eq) + ;; Case 3: 'NAME + (member value names + :test #'equal)))))))) + (and name + (not (fun-lexically-notinline-p name))))))) ;;; Return true if LVAR's only use is a call to one of the named functions ;;; (or any function if none are specified) with the specified number of