X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=6641386ef35fb72cd367e6402dfb0cbaeed223b1;hb=5745b5a5b2e3b967bf3876b4306f31b3c78495fa;hp=d23bc01b523754da7ed6320ad469b99cc5504ea8;hpb=b77ebf21b137cd0debcb7a2a1f52b093ce28ee02;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index d23bc01..6641386 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -148,6 +148,43 @@ (eq (ctran-next it) dest)) (t (eq (block-start (first (block-succ (node-block node)))) (node-prev dest)))))) + +;;; 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 +228,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)))) @@ -391,6 +428,35 @@ (awhen (node-lvar node) (lvar-dynamic-extent it))) +(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 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))) + (let ((*compiler-error-context* use)) + (compiler-notify "could not stack allocate the result of ~S" + (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)) @@ -415,15 +481,23 @@ (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 dx component)) - uses) + (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) - (awhen (fun-info-stack-allocate-result (combination-fun-info use)) - (funcall it use dx)))) + (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) @@ -493,6 +567,43 @@ 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) (or (block-delete-p block) @@ -692,7 +803,8 @@ (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 @@ -704,8 +816,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 @@ -739,7 +853,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 @@ -1141,6 +1256,14 @@ (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. +(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))))) + ;;; 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. @@ -1183,6 +1306,8 @@ (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) @@ -1539,9 +1664,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)) @@ -1551,7 +1676,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) @@ -1572,7 +1698,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) @@ -1677,10 +1839,26 @@ ((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 (vector character) bit-vector))))) + ;; 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)) @@ -1783,11 +1961,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) @@ -2009,3 +2189,16 @@ (eq (global-var-kind leaf) :global-function) (not (null (member (leaf-source-name leaf) names :test #'equal)))))))) + +;;; 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)))))))