X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=34a9a58a9c0b00ad3cc59d6b58d945373ea10e6a;hb=8f45dd3a5a074998e1aa697ba8f2a8b1b7388427;hp=2beb884520cc2d15441216f0e0b358a01964e13c;hpb=6822034325136cde4e14773c83c3769b42721306;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 2beb884..34a9a58 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -403,15 +403,14 @@ ;; 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 dx)) - t) + (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) - 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 dx &optional component) (let ((uses (lvar-uses lvar))) @@ -421,6 +420,79 @@ 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)))) + +(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) @@ -1069,6 +1141,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. @@ -1605,10 +1685,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)) @@ -1926,14 +2022,14 @@ (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 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))))))))