X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=19e0adb3e8502e6806853b3e5c23b3045dae511b;hb=091f0c20d4661994be7be4cc707c2aba4ef86418;hp=7b68ff8f282bbf0a9b8e6f18d87ebe630e454c52;hpb=36a379d746b9eb74ba8c5afff40dc5dcb9f4557a;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 7b68ff8..19e0adb 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -62,6 +62,15 @@ uses (list uses)))) +(declaim (ftype (sfunction (lvar) lvar) principal-lvar)) +(defun principal-lvar (lvar) + (labels ((pl (lvar) + (let ((use (lvar-uses lvar))) + (if (cast-p use) + (pl (cast-value use)) + lvar)))) + (pl lvar))) + (defun principal-lvar-use (lvar) (labels ((plu (lvar) (declare (type lvar lvar)) @@ -182,7 +191,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)))) @@ -382,6 +391,144 @@ (awhen (node-lvar node) (lvar-dynamic-extent it))) +(defun flushable-combination-p (call) + (declare (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))))) + +(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)) + 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 + ;; 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 (dx-combination-p use dx) + (and (cast-p use) + (not (cast-type-check use)) + (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 dx &optional component) + (let ((uses (lvar-uses lvar))) + (if (listp 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) + (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 (lvar-dest (ref-lvar var-ref)))) + (unless (and (combination-p dest) (recurse dest)) + (return-from combination-args-flow-cleanly-p nil))))))))))) + (recurse combination1))) + +(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))) + (let ((home (lambda-var-home var)) + (refs (lambda-var-refs var))) + ;; bound by a system lambda, no other REFS + (when (and (lambda-system-lambda-p home) + (eq use (car refs)) (not (cdr refs))) + ;; 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)) + (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))))) + (declaim (inline block-to-be-deleted-p)) (defun block-to-be-deleted-p (block) (or (block-delete-p block) @@ -611,7 +758,10 @@ (destructuring-bind (name . thing) var (declare (ignore name)) (etypecase thing - (leaf nil) + ;; The evaluator will mark lexicals with :BOGUS when it + ;; translates an interpreter lexenv to a compiler + ;; lexenv. + ((or leaf #!+sb-eval (member :bogus)) nil) (cons (aver (eq (car thing) 'macro)) t) (heap-alien-info nil))))) @@ -788,6 +938,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)))) @@ -1026,6 +1177,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. @@ -1068,6 +1227,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) @@ -1422,11 +1583,11 @@ ;;; of arguments changes, the transform must be prepared to return a ;;; lambda with a new lambda-list with the correct number of ;;; arguments. -(defun extract-fun-args (lvar fun num-args) +(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)) @@ -1436,7 +1597,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) @@ -1457,7 +1619,59 @@ (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) + (type (or symbol list) fun) + (type index num-args)) + (let ((fun (if (listp fun) fun (list fun)))) + (let ((inside (lvar-uses lvar))) + (unless (combination-p inside) + (give-up-ir1-transform)) + (let ((inside-fun (combination-fun inside))) + (unless (member (lvar-fun-name inside-fun) fun) + (give-up-ir1-transform)) + (let ((inside-args (combination-args inside))) + (unless (= (length inside-args) num-args) + (give-up-ir1-transform)) + (values (lvar-fun-name inside-fun) inside-args)))))) (defun flush-combination (combination) (declare (type combination combination)) @@ -1508,22 +1722,71 @@ ;;; Return a LEAF which represents the specified constant object. If ;;; the object is not in *CONSTANTS*, then we create a new constant -;;; LEAF and enter it. -(defun find-constant (object) - (if (typep object - ;; FIXME: What is the significance of this test? ("things - ;; that are worth uniquifying"?) - '(or symbol number character instance)) - (or (gethash object *constants*) - (setf (gethash object *constants*) - (make-constant :value object - :%source-name '.anonymous. - :type (ctype-of object) - :where-from :defined))) - (make-constant :value object - :%source-name '.anonymous. - :type (ctype-of object) - :where-from :defined))) +;;; 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. +;;; +;;; 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 @@ -1610,6 +1873,15 @@ nil)) nil))) +(defun lvar-fun-debug-name (lvar) + (declare (type lvar lvar)) + (let ((uses (lvar-uses lvar))) + (flet ((name1 (use) + (leaf-debug-name (ref-leaf use)))) + (if (ref-p uses) + (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) @@ -1824,3 +2096,24 @@ (setf (node-reoptimize node) t) (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. +(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)))))))) + +(defun lvar-matches (lvar &key fun-names arg-count) + (let ((use (lvar-use lvar))) + (and (combination-p use) + (or (not fun-names) + (member (combination-fun-source-name use) + fun-names :test #'eq)) + (or (not arg-count) + (= arg-count (length (combination-args use)))))))