(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.
;;;
(lvar-dynamic-extent it)))
(defun flushable-combination-p (call)
- (declare (combination call))
+ (declare (type combination call))
(let ((kind (combination-kind call))
(info (combination-fun-info call)))
(when (and (eq kind :known) (fun-info-p info))
(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
(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)))
+ ;; 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 system lambda, no other REFS
(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
;;; 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 ((policy (lexenv-%policy *lexenv*)))
- (dolist (functional (defined-fun-functionals defined-fun))
- (when (equal policy (lexenv-%policy (functional-lexenv functional)))
- (return functional)))))
+ (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
(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)
(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)
+;;; 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)))))
- (when (or errorp (leaf-has-source-name-p leaf))
- (leaf-source-name leaf))))
+ (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)
(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)))
(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.
+;;; 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 ((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))))))))
-
+ (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-use lvar)))
+ (let ((use (lvar-uses lvar)))
(and (combination-p use)
(or (not fun-names)
- (member (combination-fun-source-name use)
- fun-names :test #'eq))
+ (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)))))))
projects / sbcl.git / blobdiff