;; If next-cont does have a dest, it must be
;; unreachable, since there are no uses.
;; DELETE-CONTINUATION will mark the dest block as
- ;; delete-p [and also this block, unless it is no
+ ;; DELETE-P [and also this block, unless it is no
;; longer backward reachable from the dest block.]
(delete-continuation next-cont)
(setf (node-prev next-node) last-cont)
(defun ir1-optimize-return (node)
(declare (type creturn node))
(let* ((tails (lambda-tail-set (return-lambda node)))
- (funs (tail-set-functions tails)))
+ (funs (tail-set-funs tails)))
(collect ((res *empty-type* values-type-union))
(dolist (fun funs)
(let ((return (lambda-return fun)))
(when (type/= (res) (tail-set-type tails))
(setf (tail-set-type tails) (res))
- (dolist (fun (tail-set-functions tails))
+ (dolist (fun (tail-set-funs tails))
(dolist (ref (leaf-refs fun))
(reoptimize-continuation (node-cont ref)))))))
(flush-dest test)
(when (rest (block-succ block))
(unlink-blocks block victim))
- (setf (component-reanalyze (block-component (node-block node))) t)
+ (setf (component-reanalyze (node-component node)) t)
(unlink-node node))))
(values))
-;;; Create a new copy of an IF Node that tests the value of the node
-;;; Use. The test must have >1 use, and must be immediately used by
-;;; Use. Node must be the only node in its block (implying that
+;;; Create a new copy of an IF node that tests the value of the node
+;;; USE. The test must have >1 use, and must be immediately used by
+;;; USE. NODE must be the only node in its block (implying that
;;; block-start = if-test).
;;;
;;; This optimization has an effect semantically similar to the
;;; become unreachable, resulting in a spurious note.
(defun convert-if-if (use node)
(declare (type node use) (type cif node))
- (with-ir1-environment node
+ (with-ir1-environment-from-node node
(let* ((block (node-block node))
(test (if-test node))
(cblock (if-consequent node))
:consequent cblock
:alternative ablock))
(new-block (continuation-starts-block new-cont)))
- (prev-link new-node new-cont)
+ (link-node-to-previous-continuation new-node new-cont)
(setf (continuation-dest new-cont) new-node)
(add-continuation-use new-node dummy-cont)
(setf (block-last new-block) new-node)
;; cross-compiler doesn't know how to evaluate it.
#+sb-xc-host
(let* ((ref (continuation-use (combination-fun node)))
- (fun (leaf-name (ref-leaf ref))))
- (fboundp fun)))
+ (fun-name (leaf-source-name (ref-leaf ref))))
+ (fboundp fun-name)))
(constant-fold-call node)
(return-from ir1-optimize-combination)))
;;; wondering if something should be done to special-case the call. If
;;; CALL is a call to a global function, then see whether it defined
;;; or known:
-;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert
+;;; -- If a DEFINED-FUN should be inline expanded, then convert
;;; the expansion and change the call to call it. Expansion is
;;; enabled if :INLINE or if SPACE=0. If the FUNCTIONAL slot is
;;; true, we never expand, since this function has already been
(declare (type combination call))
(let* ((ref (continuation-use (basic-combination-fun call)))
(leaf (when (ref-p ref) (ref-leaf ref)))
- (inlinep (if (defined-function-p leaf)
- (defined-function-inlinep leaf)
+ (inlinep (if (defined-fun-p leaf)
+ (defined-fun-inlinep leaf)
:no-chance)))
(cond
((eq inlinep :notinline) (values nil nil))
(:inline t)
(:no-chance nil)
((nil :maybe-inline) (policy call (zerop space))))
- (defined-function-inline-expansion leaf)
- (let ((fun (defined-function-functional leaf)))
+ ;; FIXME: In sbcl-0.pre7.87, it looks as though we'll
+ ;; get here when LEAF is a GLOBAL-VAR (not a DEFINED-FUN)
+ ;; whenever (ZEROP SPACE), in which case we'll die with
+ ;; a type error when we try to access LEAF as a DEFINED-FUN.
+ (defined-fun-inline-expansion leaf)
+ (let ((fun (defined-fun-functional leaf)))
(or (not fun)
(and (eq inlinep :inline) (functional-kind fun))))
(inline-expansion-ok call))
(flet ((frob ()
(let ((res (ir1-convert-lambda-for-defun
- (defined-function-inline-expansion leaf)
+ (defined-fun-inline-expansion leaf)
leaf t
#'ir1-convert-inline-lambda)))
- (setf (defined-function-functional leaf) res)
+ (setf (defined-fun-functional leaf) res)
(change-ref-leaf ref res))))
(if ir1-p
(frob)
- (with-ir1-environment call
+ (with-ir1-environment-from-node call
(frob)
- (local-call-analyze *current-component*))))
+ (locall-analyze-component *current-component*))))
(values (ref-leaf (continuation-use (basic-combination-fun call)))
nil))
(t
- (let* ((name (leaf-name leaf))
+ (let* ((name (leaf-source-name leaf))
(info (info :function :info
(if (slot-accessor-p leaf)
- (if (consp name)
- '%slot-setter
- '%slot-accessor)
- name))))
+ (if (consp source-name) ; i.e. if SETF function
+ '%slot-setter
+ '%slot-accessor)
+ name))))
(if info
(values leaf (setf (basic-combination-kind call) info))
(values leaf nil)))))))
(values nil nil))))
;;; This is called by IR1-OPTIMIZE when the function for a call has
-;;; changed. If the call is local, we try to let-convert it, and
+;;; changed. If the call is local, we try to LET-convert it, and
;;; derive the result type. If it is a :FULL call, we validate it
;;; against the type, which recognizes known calls, does inline
;;; expansion, etc. If a call to a predicate in a non-conditional
(continuation-use (basic-combination-fun call))
call))
((not leaf))
- ((or (info :function :source-transform (leaf-name leaf))
+ ((or (info :function :source-transform (leaf-source-name leaf))
(and info
(ir1-attributep (function-info-attributes info)
predicate)
(let ((dest (continuation-dest (node-cont call))))
(and dest (not (if-p dest))))))
- (let ((name (leaf-name leaf)))
- (when (symbolp name)
- (let ((dums (make-gensym-list (length
- (combination-args call)))))
- (transform-call call
- `(lambda ,dums
- (,name ,@dums))))))))))))
+ (when (and (leaf-has-source-name-p leaf)
+ ;; FIXME: This SYMBOLP is part of a literal
+ ;; translation of a test in the old CMU CL
+ ;; source, and it's not quite clear what
+ ;; the old source meant. Did it mean "has a
+ ;; valid name"? Or did it mean "is an
+ ;; ordinary function name, not a SETF
+ ;; function"? Either way, the old CMU CL
+ ;; code probably didn't deal with SETF
+ ;; functions correctly, and neither does
+ ;; this new SBCL code, and that should be fixed.
+ (symbolp (leaf-source-name leaf)))
+ (let ((dummies (make-gensym-list (length
+ (combination-args call)))))
+ (transform-call call
+ `(lambda ,dummies
+ (,(leaf-source-name leaf)
+ ,@dummies)))))))))))
(values))
\f
;;;; known function optimization
;;; integrated into the control flow.
(defun transform-call (node res)
(declare (type combination node) (list res))
- (with-ir1-environment node
- (let ((new-fun (ir1-convert-inline-lambda res))
+ (with-ir1-environment-from-node node
+ (let ((new-fun (ir1-convert-inline-lambda
+ res
+ :debug-name "something inlined in TRANSFORM-CALL"))
(ref (continuation-use (combination-fun node))))
(change-ref-leaf ref new-fun)
(setf (combination-kind node) :full)
- (local-call-analyze *current-component*)))
+ (locall-analyze-component *current-component*)))
(values))
;;; Replace a call to a foldable function of constant arguments with
;;; the result of evaluating the form. We insert the resulting
;;; constant node after the call, stealing the call's continuation. We
-;;; give the call a continuation with no Dest, which should cause it
+;;; give the call a continuation with no DEST, which should cause it
;;; and its arguments to go away. If there is an error during the
;;; evaluation, we give a warning and leave the call alone, making the
;;; call a :ERROR call.
(declare (type combination call))
(let* ((args (mapcar #'continuation-value (combination-args call)))
(ref (continuation-use (combination-fun call)))
- (fun (leaf-name (ref-leaf ref))))
+ (fun-name (leaf-source-name (ref-leaf ref))))
(multiple-value-bind (values win)
- (careful-call fun args call "constant folding")
+ (careful-call fun-name args call "constant folding")
(if (not win)
(setf (combination-kind call) :error)
(let ((dummies (make-gensym-list (length args))))
((or constant functional) t)
(lambda-var
(null (lambda-var-sets leaf)))
- (defined-function
- (not (eq (defined-function-inlinep leaf) :notinline)))
+ (defined-fun
+ (not (eq (defined-fun-inlinep leaf) :notinline)))
(global-var
(case (global-var-kind leaf)
- (:global-function t)
- (:constant t))))))
+ (:global-function t))))))
;;; If we have a non-set LET var with a single use, then (if possible)
;;; replace the variable reference's CONT with the arg continuation.
;;; changes. We look at each changed argument. If the corresponding
;;; variable is set, then we call PROPAGATE-FROM-SETS. Otherwise, we
;;; consider substituting for the variable, and also propagate
-;;; derived-type information for the arg to all the Var's refs.
+;;; derived-type information for the arg to all the VAR's refs.
;;;
;;; Substitution is inhibited when the arg leaf's derived type isn't a
;;; subtype of the argument's asserted type. This prevents type
;;;
;;; Substitution of individual references is inhibited if the
;;; reference is in a different component from the home. This can only
-;;; happen with closures over top-level lambda vars. In such cases,
+;;; happen with closures over top level lambda vars. In such cases,
;;; the references may have already been compiled, and thus can't be
;;; retroactively modified.
;;;
;;; are done, then we delete the LET.
;;;
;;; Note that we are responsible for clearing the
-;;; Continuation-Reoptimize flags.
+;;; CONTINUATION-REOPTIMIZE flags.
(defun propagate-let-args (call fun)
(declare (type combination call) (type clambda fun))
(loop for arg in (combination-args call)
(values-subtypep (leaf-type leaf)
(continuation-asserted-type arg)))
(propagate-to-refs var (continuation-type arg))
- (let ((this-comp (block-component (node-block use))))
+ (let ((use-component (node-component use)))
(substitute-leaf-if
#'(lambda (ref)
- (cond ((eq (block-component (node-block ref))
- this-comp)
+ (cond ((eq (node-component ref) use-component)
t)
(t
- (aver (eq (functional-kind (lambda-home fun))
- :top-level))
+ (aver (lambda-toplevelish-p (lambda-home fun)))
nil)))
leaf var))
t)))))
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
- (unless (or (functional-entry-function fun)
+ (unless (or (functional-entry-fun fun)
(lambda-optional-dispatch fun))
(let* ((vars (lambda-vars fun))
(union (mapcar #'(lambda (arg var)
min)
(t nil))))
(when count
- (with-ir1-environment node
+ (with-ir1-environment-from-node node
(let* ((dums (make-gensym-list count))
(ignore (gensym))
(fun (ir1-convert-lambda
(funcall ,(ref-leaf ref) ,@dums)))))
(change-ref-leaf ref fun)
(aver (eq (basic-combination-kind node) :full))
- (local-call-analyze *current-component*)
+ (locall-analyze-component *current-component*)
(aver (eq (basic-combination-kind node) :local)))))))))
(values))
(mapc #'flush-dest (subseq vals nvars))
(setq vals (subseq vals 0 nvars)))
((< nvals nvars)
- (with-ir1-environment use
+ (with-ir1-environment-from-node use
(let ((node-prev (node-prev use)))
(setf (node-prev use) nil)
(setf (continuation-next node-prev) nil)
do (reference-constant prev cont nil)
(res cont))
(setq vals (res)))
- (prev-link use (car (last vals)))))))
+ (link-node-to-previous-continuation use
+ (car (last vals)))))))
(setf (combination-args use) vals)
(flush-dest (combination-fun use))
(let ((fun-cont (basic-combination-fun call)))
projects / sbcl.git / blobdiff