(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))))))))
\f
;;;; lvar substitution
(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))
(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
(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))
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)
(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
(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
nil
(lexenv-handled-conditions lexenv)
(lexenv-disabled-package-locks lexenv)
- (lexenv-policy lexenv))))
+ (lexenv-policy lexenv)
+ (lexenv-user-data lexenv))))
\f
;;;; flow/DFO/component hackery
(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
(all (combination-args call))
(new-args (reverse (subseq all 0 n-positional)))
(key-args (subseq all n-positional))
- (parameters nil))
+ (parameters nil)
+ (flushed-keys nil))
(loop while key-args
do (let* ((key (pop key-args))
(val (pop key-args))
(spec (or (assoc keyword specs :test #'eq)
(give-up-ir1-transform))))
(push val new-args)
- (flush-dest key)
+ (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)))
(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)
(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)))
(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-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