X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=7d9f2f3d4842fe0449cf891513d32e744b220df5;hb=HEAD;hp=29fa7cde14b55c05a77dd94d4e611b808023e6e8;hpb=1ab8bfcc2145a100795401de5941c373bb6318eb;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 29fa7cd..7d9f2f3 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. ;;; @@ -101,7 +110,7 @@ (first new-uses) new-uses))) (setf (lvar-uses lvar) nil)) - (setf (node-lvar node) nil))) + (flush-node node))) (values)) ;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete ;;; its DEST's block, which must be unreachable. @@ -148,6 +157,53 @@ (eq (ctran-next it) dest)) (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. +;;; +;;; Uninteresting nodes are nodes in the same block which are either +;;; REFs, external CASTs to the same destination, or known combinations +;;; that never unwind. +(defun almost-immediately-used-p (lvar node) + (declare (type lvar lvar) + (type node node)) + (aver (eq (node-lvar node) lvar)) + (let ((dest (lvar-dest lvar))) + (tagbody + :next + (let ((ctran (node-next node))) + (cond (ctran + (setf node (ctran-next ctran)) + (if (eq node dest) + (return-from almost-immediately-used-p t) + (typecase node + (ref + (go :next)) + (cast + (when (and (eq :external (cast-type-check node)) + (eq dest (node-dest node))) + (go :next))) + (combination + ;; KLUDGE: Unfortunately we don't have an attribute for + ;; "never unwinds", so we just special case + ;; %ALLOCATE-CLOSURES: it is easy to run into with eg. + ;; FORMAT and a non-constant first argument. + (when (eq '%allocate-closures (combination-fun-source-name node nil)) + (go :next)))))) + (t + (when (eq (block-start (first (block-succ (node-block node)))) + (node-prev dest)) + (return-from almost-immediately-used-p t)))))))) ;;;; lvar substitution @@ -191,7 +247,7 @@ (setf (lvar-dynamic-extent old) nil) (unless (lvar-dynamic-extent new) (setf (lvar-dynamic-extent new) it) - (setf (cleanup-info it) (substitute new old (cleanup-info it))))) + (setf (cleanup-info it) (subst new old (cleanup-info it))))) (when (lvar-dynamic-extent new) (do-uses (node new) (node-ends-block node)))) @@ -266,9 +322,9 @@ ;;;; ;;; Filter values of LVAR through FORM, which must be an ordinary/mv -;;; call. First argument must be 'DUMMY, which will be replaced with -;;; LVAR. In case of an ordinary call the function should not have -;;; return type NIL. We create a new "filtered" lvar. +;;; call. Exactly one argument must be 'DUMMY, which will be replaced +;;; with LVAR. In case of an ordinary call the function should not +;;; have return type NIL. We create a new "filtered" lvar. ;;; ;;; TODO: remove preconditions. (defun filter-lvar (lvar form) @@ -302,11 +358,18 @@ ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because ;; no LET conversion has been done yet.) The [mv-]combination ;; code from the call in the form will be the use of the new - ;; check lvar. We substitute for the first argument of - ;; this node. + ;; check lvar. We substitute exactly one argument. (let* ((node (lvar-use filtered-lvar)) - (args (basic-combination-args node)) - (victim (first args))) + victim) + (dolist (arg (basic-combination-args node) (aver victim)) + (let* ((arg (principal-lvar arg)) + (use (lvar-use arg)) + leaf) + (when (and (ref-p use) + (constant-p (setf leaf (ref-leaf use))) + (eql (constant-value leaf) 'dummy)) + (aver (not victim)) + (setf victim arg)))) (aver (eq (constant-value (ref-leaf (lvar-use victim))) 'dummy)) @@ -391,37 +454,215 @@ (awhen (node-lvar node) (lvar-dynamic-extent it))) -(declaim (ftype (sfunction (node &optional (or null component)) boolean) - use-good-for-dx-p)) -(declaim (ftype (sfunction (lvar &optional (or null component)) boolean) - lvar-good-for-dx-p)) -(defun use-good-for-dx-p (use &optional component) +(defun flushable-combination-p (call) + (declare (type combination call)) + (let ((kind (combination-kind call)) + (info (combination-fun-info call))) + (when (and (eq kind :known) (fun-info-p info)) + (let ((attr (fun-info-attributes info))) + (when (and (not (ir1-attributep attr call)) + ;; FIXME: For now, don't consider potentially flushable + ;; calls flushable when they have the CALL attribute. + ;; Someday we should look at the functional args to + ;; determine if they have any side effects. + (if (policy call (= safety 3)) + (ir1-attributep attr flushable) + (ir1-attributep attr unsafely-flushable))) + t))))) + +;;;; 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)) + ;; 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)) + (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? - ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that - ;; is, that the PRINCIPAL-LVAR is always in the same component - ;; as the original one. It would be either good to have an - ;; explanation of why casts don't point across components, or an - ;; explanation of when they do it. ...in the meanwhile AVER that - ;; our expactation holds true. + ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the + ;; PRINCIPAL-LVAR is always in the same component as the original one. It + ;; would be either good to have an explanation of why casts don't point + ;; across components, or an explanation of when they do it. ...in the + ;; meanwhile AVER that our assumption holds true. (aver (or (not component) (eq component (node-component use)))) - (or (and (combination-p use) - (eq (combination-kind use) :known) - (awhen (fun-info-stack-allocate-result - (combination-fun-info use)) - (funcall it use)) - t) + (or (dx-combination-p use dx) (and (cast-p use) (not (cast-type-check use)) - (lvar-good-for-dx-p (cast-value use) component) - t))) + (lvar-good-for-dx-p (cast-value use) dx component)) + (and (trivial-lambda-var-ref-p use) + (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use)))) + (or (eq use uses) + (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx component)))))) -(defun lvar-good-for-dx-p (lvar &optional component) +(defun lvar-good-for-dx-p (lvar dx &optional component) (let ((uses (lvar-uses lvar))) (if (listp uses) - (every (lambda (use) - (use-good-for-dx-p use component)) - uses) - (use-good-for-dx-p uses component)))) + (when uses + (every (lambda (use) + (use-good-for-dx-p use dx component)) + uses)) + (use-good-for-dx-p uses dx component)))) + +(defun known-dx-combination-p (use dx) + (and (eq (combination-kind use) :known) + (let ((info (combination-fun-info use))) + (or (awhen (fun-info-stack-allocate-result info) + (funcall it use dx)) + (awhen (fun-info-result-arg info) + (let ((args (combination-args use))) + (lvar-good-for-dx-p (if (zerop it) + (car args) + (nth it args)) + dx))))))) + +(defun dx-combination-p (use dx) + (and (combination-p use) + (or + ;; Known, and can do DX. + (known-dx-combination-p use dx) + ;; Possibly a not-yet-eliminated lambda which ends up returning the + ;; results of an actual known DX combination. + (let* ((fun (combination-fun use)) + (ref (principal-lvar-use fun)) + (clambda (when (ref-p ref) + (ref-leaf ref))) + (creturn (when (lambda-p clambda) + (lambda-return clambda))) + (result-use (when (return-p creturn) + (principal-lvar-use (return-result creturn))))) + ;; FIXME: We should be able to deal with multiple uses here as well. + (and (dx-combination-p result-use dx) + (combination-args-flow-cleanly-p use result-use dx)))))) + +(defun combination-args-flow-cleanly-p (combination1 combination2 dx) + (labels ((recurse (combination) + (or (eq combination combination2) + (if (known-dx-combination-p combination dx) + (let ((dest (lvar-dest (combination-lvar combination)))) + (and (combination-p dest) + (recurse dest))) + (let* ((fun1 (combination-fun combination)) + (ref1 (principal-lvar-use fun1)) + (clambda1 (when (ref-p ref1) (ref-leaf ref1)))) + (when (lambda-p clambda1) + (dolist (var (lambda-vars clambda1) t) + (dolist (var-ref (lambda-var-refs var)) + (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))) + ;; 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 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) + (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)) + (primary (car lambda-refs))) + (and (ref-p primary) + (not (cdr lambda-refs)) + (combination-p (lvar-dest (ref-lvar primary))))))))))) + +(defun trivial-lambda-var-ref-lvar (use) + (let* ((this (ref-leaf use)) + (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) + (let ((uses (lvar-uses lvar))) + ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS. + ;; Uses of mupltiple-use LVARs already end their blocks, so we just need + ;; to process uses of single-use LVARs. + (when (node-p uses) + (node-ends-block uses)) + ;; If this LVAR's USE is good for DX, it is either a CAST, or it + ;; must be a regular combination whose arguments are potentially DX as well. + (flet ((recurse (use) + (etypecase use + (cast + (handle-nested-dynamic-extent-lvars + dx (cast-value use) recheck-component)) + (combination + (loop for arg in (combination-args use) + ;; deleted args show up as NIL here + when (and arg + (lvar-good-for-dx-p arg dx recheck-component)) + append (handle-nested-dynamic-extent-lvars + dx arg recheck-component))) + (ref + (let* ((other (trivial-lambda-var-ref-lvar use))) + (unless (eq other lvar) + (handle-nested-dynamic-extent-lvars + dx other recheck-component))))))) + (cons (cons dx lvar) + (if (listp uses) + (loop for use in uses + when (use-good-for-dx-p use dx recheck-component) + nconc (recurse use)) + (when (use-good-for-dx-p uses dx recheck-component) + (recurse uses))))))) + +;;;;; BLOCK UTILS (declaim (inline block-to-be-deleted-p)) (defun block-to-be-deleted-p (block) @@ -524,11 +765,26 @@ (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))))) @@ -541,6 +797,30 @@ (values nil nil) (values (node-source-form use) t)))) +(defun common-suffix (x y) + (let ((mismatch (mismatch x y :from-end t))) + (if mismatch + (subseq x mismatch) + x))) + +;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a +;;; singleton. Otherwise, return a list of the lowest common +;;; ancestor source form of all the uses (if it can be found), +;;; followed by all the uses' source forms. +(defun lvar-all-sources (lvar) + (let ((use (lvar-uses lvar))) + (if (listp use) + (let ((forms '()) + (path (node-source-path (first use)))) + (dolist (use use (cons (if (find 'original-source-start path) + (find-original-source path) + "a hairy form") + forms)) + (pushnew (node-source-form use) forms) + (setf path (common-suffix path + (node-source-path use))))) + (list (node-source-form use))))) + ;;; Return the unique node, delivering a value to LVAR. #!-sb-fluid (declaim (inline lvar-use)) (defun lvar-use (lvar) @@ -612,7 +892,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 @@ -622,11 +902,12 @@ (handled-conditions (lexenv-handled-conditions default)) (disabled-package-locks (lexenv-disabled-package-locks default)) - (policy (lexenv-policy default))) + (policy (lexenv-policy default)) + (user-data (lexenv-user-data default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) (if ,var - (nconc ,var old) + (append ,var old) old)))) (internal-make-lexenv (frob funs lexenv-funs) @@ -634,8 +915,10 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup handled-conditions - disabled-package-locks policy))) + lambda + cleanup handled-conditions disabled-package-locks + policy + user-data))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced ;;; macroexpander @@ -669,7 +952,8 @@ nil (lexenv-handled-conditions lexenv) (lexenv-disabled-package-locks lexenv) - (lexenv-policy lexenv)))) + (lexenv-policy lexenv) + (lexenv-user-data lexenv)))) ;;;; flow/DFO/component hackery @@ -832,6 +1116,7 @@ (let* ((block (node-block node)) (start (node-next node)) (last (block-last block))) + (check-type last node) (unless (eq last node) (aver (and (eq (ctran-kind start) :inside-block) (not (block-delete-p block)))) @@ -866,6 +1151,7 @@ (defun delete-lambda-var (leaf) (declare (type lambda-var leaf)) + (setf (lambda-var-deleted leaf) t) ;; Iterate over all local calls flushing the corresponding argument, ;; allowing the computation of the argument to be deleted. We also ;; mark the LET for reoptimization, since it may be that we have @@ -1070,6 +1356,35 @@ (eq (defined-fun-functional defined-fun) fun)) (remhash name *free-funs*)))))) +;;; 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 ((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 ;;; the leaf to determine if a special action is appropriate. @@ -1089,7 +1404,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) @@ -1105,6 +1421,20 @@ (values)) +;;; This function is called to unlink a node from its LVAR; +;;; we assume that the LVAR's USE list has already been updated, +;;; and that we only have to mark the node as up for dead code +;;; elimination, and to clear it LVAR slot. +(defun flush-node (node) + (declare (type node node)) + (let* ((prev (node-prev node)) + (block (ctran-block prev))) + (reoptimize-component (block-component block) t) + (setf (block-attributep (block-flags block) + flush-p type-asserted type-check) + t)) + (setf (node-lvar node) nil)) + ;;; This function is called by people who delete nodes; it provides a ;;; way to indicate that the value of a lvar is no longer used. We ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses @@ -1112,16 +1442,12 @@ (defun flush-dest (lvar) (declare (type (or lvar null) lvar)) (unless (null lvar) + (when (lvar-dynamic-extent lvar) + (note-no-stack-allocation lvar :flush t)) (setf (lvar-dest lvar) nil) (flush-lvar-externally-checkable-type lvar) (do-uses (use lvar) - (let ((prev (node-prev use))) - (let ((block (ctran-block prev))) - (reoptimize-component (block-component block) t) - (setf (block-attributep (block-flags block) - flush-p type-asserted type-check) - t))) - (setf (node-lvar use) nil)) + (flush-node use)) (setf (lvar-uses lvar) nil)) (values)) @@ -1468,9 +1794,9 @@ ;;; arguments. (defun splice-fun-args (lvar fun num-args) #!+sb-doc - "If LVAR is a call to FUN with NUM-ARGS args, change those arguments - to feed directly to the LVAR-DEST of LVAR, which must be a - combination." + "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed +directly to the LVAR-DEST of LVAR, which must be a combination. If FUN +is :ANY, the function name is not checked." (declare (type lvar lvar) (type symbol fun) (type index num-args)) @@ -1480,7 +1806,8 @@ (unless (combination-p inside) (give-up-ir1-transform)) (let ((inside-fun (combination-fun inside))) - (unless (eq (lvar-fun-name inside-fun) fun) + (unless (or (eq fun :any) + (eq (lvar-fun-name inside-fun) fun)) (give-up-ir1-transform)) (let ((inside-args (combination-args inside))) (unless (= (length inside-args) num-args) @@ -1501,7 +1828,43 @@ (combination-kind inside) :known) (setf (node-derived-type inside) *wild-type*) (flush-dest lvar) - (values)))))) + inside-args))))) + +;;; Eliminate keyword arguments from the call (leaving the +;;; parameters in place. +;;; +;;; (FOO ... :BAR X :QUUX Y) +;;; becomes +;;; (FOO ... X Y) +;;; +;;; SPECS is a list of (:KEYWORD PARAMETER) specifications. +;;; Returns the list of specified parameters names in the +;;; order they appeared in the call. N-POSITIONAL is the +;;; number of positional arguments in th call. +(defun eliminate-keyword-args (call n-positional specs) + (let* ((specs (copy-tree specs)) + (all (combination-args call)) + (new-args (reverse (subseq all 0 n-positional))) + (key-args (subseq all n-positional)) + (parameters nil) + (flushed-keys nil)) + (loop while key-args + do (let* ((key (pop key-args)) + (val (pop key-args)) + (keyword (if (constant-lvar-p key) + (lvar-value key) + (give-up-ir1-transform))) + (spec (or (assoc keyword specs :test #'eq) + (give-up-ir1-transform)))) + (push val new-args) + (push key flushed-keys) + (push (second spec) parameters) + ;; In case of duplicate keys. + (setf (second spec) (gensym)))) + (dolist (key flushed-keys) + (flush-dest key)) + (setf (combination-args call) (reverse new-args)) + (reverse parameters))) (defun extract-fun-args (lvar fun num-args) (declare (type lvar lvar) @@ -1531,7 +1894,7 @@ ;;;; leaf hackery ;;; Change the LEAF that a REF refers to. -(defun change-ref-leaf (ref leaf) +(defun change-ref-leaf (ref leaf &key recklessly) (declare (type ref ref) (type leaf leaf)) (unless (eq (ref-leaf ref) leaf) (push ref (leaf-refs leaf)) @@ -1546,7 +1909,7 @@ (eq lvar (basic-combination-fun dest)) (csubtypep ltype (specifier-type 'function)))) (setf (node-derived-type ref) vltype) - (derive-node-type ref vltype))) + (derive-node-type ref vltype :from-scratch recklessly))) (reoptimize-lvar (node-lvar ref))) (values)) @@ -1571,23 +1934,68 @@ ;;; LEAF and enter it. If we are producing a fasl file, make sure that ;;; MAKE-LOAD-FORM gets used on any parts of the constant that it ;;; needs to be. -(defun find-constant (object) - (flet ((make-it () - (when (producing-fasl-file) - (maybe-emit-make-load-forms object)) - (make-constant :value object - :%source-name '.anonymous. - :type (ctype-of object) - :where-from :defined))) - (if (and (typep object - ;; FIXME: What is the significance of this test? ("things - ;; that are worth uniquifying"?) - '(or symbol number character instance)) - (boundp '*constants*)) - (or (gethash object *constants*) - (setf (gethash object *constants*) - (make-it))) - (make-it)))) +;;; +;;; We are allowed to coalesce things like EQUAL strings and bit-vectors +;;; when file-compiling, but not when using COMPILE. +(defun find-constant (object &optional (name nil namep)) + (let ((faslp (producing-fasl-file))) + (labels ((make-it () + (when faslp + (if namep + (maybe-emit-make-load-forms object name) + (maybe-emit-make-load-forms object))) + (make-constant object)) + (core-coalesce-p (x) + ;; True for things which retain their identity under EQUAL, + ;; so we can safely share the same CONSTANT leaf between + ;; multiple references. + (or (typep x '(or symbol number character)) + ;; Amusingly enough, we see CLAMBDAs --among other things-- + ;; here, from compiling things like %ALLOCATE-CLOSUREs forms. + ;; No point in stuffing them in the hash-table. + (and (typep x 'instance) + (not (or (leaf-p x) (node-p x)))))) + (file-coalesce-p (x) + ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various + ;; other things when file-compiling. + (or (core-coalesce-p x) + (if (consp x) + (if (eq +code-coverage-unmarked+ (cdr x)) + ;; These are already coalesced, and the CAR should + ;; always be OK, so no need to check. + t + (unless (maybe-cyclic-p x) ; safe for EQUAL? + (do ((y x (cdr y))) + ((atom y) (file-coalesce-p y)) + (unless (file-coalesce-p (car y)) + (return nil))))) + ;; We *could* coalesce base-strings as well, + ;; but we'd need a separate hash-table for + ;; that, since we are not allowed to coalesce + ;; base-strings with non-base-strings. + (typep x + '(or bit-vector + ;; in the cross-compiler, we coalesce + ;; all strings with the same contents, + ;; because we will end up dumping them + ;; as base-strings anyway. In the + ;; real compiler, we're not allowed to + ;; coalesce regardless of string + ;; specialized element type, so we + ;; KLUDGE by coalescing only character + ;; strings (the common case) and + ;; punting on the other types. + #+sb-xc-host + string + #-sb-xc-host + (vector character)))))) + (coalescep (x) + (if faslp (file-coalesce-p x) (core-coalesce-p x)))) + (if (and (boundp '*constants*) (coalescep object)) + (or (gethash object *constants*) + (setf (gethash object *constants*) + (make-it))) + (make-it))))) ;;; Return true if VAR would have to be closed over if environment ;;; analysis ran now (i.e. if there are any uses that have a different @@ -1683,11 +2091,13 @@ (name1 uses) (mapcar #'name1 uses))))) -;;; Return the source name of a combination. (This is an idiom -;;; which was used in CMU CL. I gather it always works. -- WHN) -(defun combination-fun-source-name (combination) - (let ((ref (lvar-uses (combination-fun combination)))) - (leaf-source-name (ref-leaf ref)))) +;;; Return the source name of a combination -- or signals an error +;;; if the function leaf is anonymous. +(defun combination-fun-source-name (combination &optional (errorp t)) + (let ((leaf (ref-leaf (lvar-uses (combination-fun combination))))) + (if (or errorp (leaf-has-source-name-p leaf)) + (values (leaf-source-name leaf) t) + (values nil nil)))) ;;; Return the COMBINATION node that is the call to the LET FUN. (defun let-combination (fun) @@ -1755,6 +2165,15 @@ (memq (functional-kind functional) '(:deleted :zombie)))) (throw 'locall-already-let-converted functional))) +(defun assure-leaf-live-p (leaf) + (typecase leaf + (lambda-var + (when (lambda-var-deleted leaf) + (throw 'locall-already-let-converted leaf))) + (functional + (assure-functional-live-p leaf)))) + + (defun call-full-like-p (call) (declare (type combination call)) (let ((kind (basic-combination-kind call))) @@ -1898,14 +2317,63 @@ (setf (block-reoptimize (node-block node)) t) (reoptimize-component (node-component node) :maybe))))))) -;;; True if LVAR is for 'NAME, or #'NAME (global, not local) -(defun lvar-for-named-function (lvar name) - (if (constant-lvar-p lvar) - (eq name (lvar-value lvar)) - (let ((use (lvar-uses lvar))) - (and (not (listp use)) - (ref-p use) - (let ((leaf (ref-leaf use))) - (and (global-var-p leaf) - (eq :global-function (global-var-kind leaf)) - (eq name (leaf-source-name leaf)))))))) +;;; 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* ((*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 +;;; of arguments (or any number if number is not specified) +(defun lvar-matches (lvar &key fun-names arg-count) + (let ((use (lvar-uses lvar))) + (and (combination-p use) + (or (not fun-names) + (multiple-value-bind (name ok) + (combination-fun-source-name use nil) + (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))))))