X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=f522cfc4141a35d39f372b3382f9788869a614c3;hb=f22ad70037030c07074327cf239bd84dc17b44b6;hp=cba2914f78a153b935388c0ebef6c16d4a015be3;hpb=697f4d1bd284ed6b72d24f416dfb09c2779b12df;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index cba2914..f522cfc 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)) @@ -382,12 +391,37 @@ (awhen (node-lvar node) (lvar-dynamic-extent it))) -(defun use-good-for-dx-p (use) - (and (combination-p use) - (eq (combination-kind use) :known) - (awhen (fun-info-stack-allocate-result - (combination-fun-info use)) - (funcall it use)))) +(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) + ;; 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. + (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) + (and (cast-p use) + (not (cast-type-check use)) + (lvar-good-for-dx-p (cast-value use) component) + t))) + +(defun lvar-good-for-dx-p (lvar &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)))) (declaim (inline block-to-be-deleted-p)) (defun block-to-be-deleted-p (block) @@ -1534,22 +1568,55 @@ ;;; 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 (vector character) bit-vector))))) + (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 @@ -1636,6 +1703,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) @@ -1850,3 +1926,15 @@ (setf (node-reoptimize node) t) (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))))))))