(declare (type cblock block1 block2) (type node node)
(type (or cleanup null) cleanup))
(setf (component-reanalyze (block-component block1)) t)
- (with-ir1-environment node
- (let* ((start (make-continuation))
- (block (continuation-starts-block start))
- (cont (make-continuation))
- (*lexenv* (if cleanup
- (make-lexenv :cleanup cleanup)
- *lexenv*)))
- (change-block-successor block1 block2 block)
- (link-blocks block block2)
- (ir1-convert start cont form)
- (setf (block-last block) (continuation-use cont))
- block)))
+ (with-ir1-environment-from-node node
+ (with-component-last-block (*current-component*
+ (block-next (component-head *current-component*)))
+ (let* ((start (make-continuation))
+ (block (continuation-starts-block start))
+ (cont (make-continuation))
+ (*lexenv* (if cleanup
+ (make-lexenv :cleanup cleanup)
+ *lexenv*)))
+ (change-block-successor block1 block2 block)
+ (link-blocks block block2)
+ (ir1-convert start cont form)
+ (setf (block-last block) (continuation-use cont))
+ block))))
\f
;;;; continuation use hacking
(nsubst new old (basic-combination-args dest))))))
(flush-dest old)
- (setf (continuation-dest new) dest))
+ (setf (continuation-dest new) dest)
+ (setf (continuation-%externally-checkable-type new) nil))
(values))
;;; Replace all uses of OLD with uses of NEW, where NEW has an
(ecase (continuation-kind cont)
(:unused
(aver (not (continuation-block cont)))
- (let* ((head (component-head *current-component*))
- (next (block-next head))
- (new-block (make-block cont)))
- (setf (block-next new-block) next)
- (setf (block-prev new-block) head)
- (setf (block-prev next) new-block)
- (setf (block-next head) new-block)
- (setf (continuation-block cont) new-block)
- (setf (continuation-use cont) nil)
- (setf (continuation-kind cont) :block-start)
+ (let* ((next (component-last-block *current-component*))
+ (prev (block-prev next))
+ (new-block (make-block cont)))
+ (setf (block-next new-block) next
+ (block-prev new-block) prev
+ (block-prev next) new-block
+ (block-next prev) new-block
+ (continuation-block cont) new-block
+ (continuation-use cont) nil
+ (continuation-kind cont) :block-start)
new-block))
(:block-start
(continuation-block cont))))
-;;; Ensure that Cont is the start of a block (or deleted) so that the use
-;;; set can be freely manipulated.
-;;; -- If the continuation is :Unused or is :Inside-Block and the Cont of Last
-;;; in its block, then we make it the start of a new deleted block.
-;;; -- If the continuation is :Inside-Block inside a block, then we split the
-;;; block using Node-Ends-Block, which makes the continuation be a
-;;; :Block-Start.
+;;; Ensure that CONT is the start of a block (or deleted) so that
+;;; the use set can be freely manipulated.
+;;; -- If the continuation is :UNUSED or is :INSIDE-BLOCK and the
+;;; CONT of LAST in its block, then we make it the start of a new
+;;; deleted block.
+;;; -- If the continuation is :INSIDE-BLOCK inside a block, then we
+;;; split the block using NODE-ENDS-BLOCK, which makes the
+;;; continuation be a :BLOCK-START.
(defun ensure-block-start (cont)
(declare (type continuation cont))
(let ((kind (continuation-kind cont)))
\f
;;;; miscellaneous shorthand functions
-;;; Return the home (i.e. enclosing non-let) lambda for Node. Since the
-;;; LEXENV-LAMBDA may be deleted, we must chain up the LAMBDA-CALL-LEXENV
-;;; thread until we find a lambda that isn't deleted, and then return its home.
-(declaim (maybe-inline node-home-lambda))
+;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since
+;;; the LEXENV-LAMBDA may be deleted, we must chain up the
+;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't
+;;; deleted, and then return its home.
(defun node-home-lambda (node)
(declare (type node node))
(do ((fun (lexenv-lambda (node-lexenv node))
(when (eq (lambda-home fun) fun)
(return fun))))
-#!-sb-fluid (declaim (inline node-block node-tlf-number))
-(declaim (maybe-inline node-environment))
(defun node-block (node)
(declare (type node node))
(the cblock (continuation-block (node-prev node))))
-(defun node-environment (node)
+(defun node-component (node)
+ (declare (type node node))
+ (block-component (node-block node)))
+(defun node-physenv (node)
(declare (type node node))
- #!-sb-fluid (declare (inline node-home-lambda))
- (the environment (lambda-environment (node-home-lambda node))))
+ (the physenv (lambda-physenv (node-home-lambda node))))
-;;; Return the enclosing cleanup for environment of the first or last node
-;;; in BLOCK.
+(defun lambda-block (clambda)
+ (declare (type clambda clambda))
+ (node-block (lambda-bind clambda)))
+(defun lambda-component (clambda)
+ (block-component (lambda-block clambda)))
+
+;;; Return the enclosing cleanup for environment of the first or last
+;;; node in BLOCK.
(defun block-start-cleanup (block)
(declare (type cblock block))
(node-enclosing-cleanup (continuation-next (block-start block))))
(declare (type cblock block))
(node-enclosing-cleanup (block-last block)))
+;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
+;;; if there is none.
+;;;
+;;; There can legitimately be no home lambda in dead code early in the
+;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in
+;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
+;;; where the block is just a placeholder during parsing and doesn't
+;;; actually correspond to code which will be written anywhere.
+(defun block-home-lambda-or-null (block)
+ (declare (type cblock block))
+ (if (node-p (block-last block))
+ ;; This is the old CMU CL way of doing it.
+ (node-home-lambda (block-last block))
+ ;; Now that SBCL uses this operation more aggressively than CMU
+ ;; CL did, the old CMU CL way of doing it can fail in two ways.
+ ;; 1. It can fail in a few cases even when a meaningful home
+ ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of
+ ;; an IF.
+ ;; 2. It can fail when converting a form which is born orphaned
+ ;; so that it never had a meaningful home lambda, e.g. a form
+ ;; which follows a RETURN-FROM or GO form.
+ (let ((pred-list (block-pred block)))
+ ;; To deal with case 1, we reason that
+ ;; previous-in-target-execution-order blocks should be in the
+ ;; same lambda, and that they seem in practice to be
+ ;; previous-in-compilation-order blocks too, so we look back
+ ;; to find one which is sufficiently initialized to tell us
+ ;; what the home lambda is.
+ (if pred-list
+ ;; We could get fancy about this, flooding through the
+ ;; graph of all the previous blocks, but in practice it
+ ;; seems to work just to grab the first previous block and
+ ;; use it.
+ (node-home-lambda (block-last (first pred-list)))
+ ;; In case 2, we end up with an empty PRED-LIST and
+ ;; have to punt: There's no home lambda.
+ nil))))
+
;;; Return the non-LET LAMBDA that holds BLOCK's code.
(defun block-home-lambda (block)
- (declare (type cblock block))
- #!-sb-fluid (declare (inline node-home-lambda))
- (node-home-lambda (block-last block)))
+ (the clambda
+ (block-home-lambda-or-null block)))
-;;; Return the IR1 environment for BLOCK.
-(defun block-environment (block)
+;;; Return the IR1 physical environment for BLOCK.
+(defun block-physenv (block)
(declare (type cblock block))
- #!-sb-fluid (declare (inline node-home-lambda))
- (lambda-environment (node-home-lambda (block-last block))))
+ (lambda-physenv (block-home-lambda block)))
;;; Return the Top Level Form number of PATH, i.e. the ordinal number
-;;; of its original source's top-level form in its compilation unit.
+;;; of its original source's top level form in its compilation unit.
(defun source-path-tlf-number (path)
(declare (list path))
(car (last path)))
(if use
(values (node-source-form use) t)
(values nil nil))))
+
+;;; Return the LAMBDA that is CONT's home, or NIL if there is none.
+(defun continuation-home-lambda-or-null (cont)
+ ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
+ ;; implementation might not be quite right, or might be uglier than
+ ;; necessary. It appears that the original Python never found a need
+ ;; to do this operation. The obvious things based on
+ ;; NODE-HOME-LAMBDA of CONTINUATION-USE usually work; then if that
+ ;; fails, BLOCK-HOME-LAMBDA of CONTINUATION-BLOCK works, given that
+ ;; we generalize it enough to grovel harder when the simple CMU CL
+ ;; approach fails, and furthermore realize that in some exceptional
+ ;; cases it might return NIL. -- WHN 2001-12-04
+ (cond ((continuation-use cont)
+ (node-home-lambda (continuation-use cont)))
+ ((continuation-block cont)
+ (block-home-lambda-or-null (continuation-block cont)))
+ (t
+ (bug "confused about home lambda for ~S"))))
+
+;;; Return the LAMBDA that is CONT's home.
+(defun continuation-home-lambda (cont)
+ (the clambda
+ (continuation-home-lambda-or-null cont)))
+
+#!-sb-fluid (declaim (inline continuation-single-value-p))
+(defun continuation-single-value-p (cont)
+ (not (typep (continuation-dest cont)
+ '(or creturn exit mv-combination))))
\f
;;; Return a new LEXENV just like DEFAULT except for the specified
;;; slot values. Values for the alist slots are NCONCed to the
;;; beginning of the current value, rather than replacing it entirely.
(defun make-lexenv (&key (default *lexenv*)
- functions variables blocks tags type-restrictions
- options
+ funs vars blocks tags
+ type-restrictions weakend-type-restrictions
(lambda (lexenv-lambda default))
(cleanup (lexenv-cleanup default))
(policy (lexenv-policy default)))
(nconc ,var old)
old))))
(internal-make-lexenv
- (frob functions lexenv-functions)
- (frob variables lexenv-variables)
+ (frob funs lexenv-funs)
+ (frob vars lexenv-vars)
(frob blocks lexenv-blocks)
(frob tags lexenv-tags)
(frob type-restrictions lexenv-type-restrictions)
- lambda cleanup policy
- (frob options lexenv-options))))
+ (frob weakend-type-restrictions lexenv-weakend-type-restrictions)
+ lambda cleanup policy)))
+
+;;; Makes a LEXENV, suitable for using in a MACROLET introduced
+;;; macroexpander
+(defun make-restricted-lexenv (lexenv)
+ (flet ((fun-good-p (fun)
+ (destructuring-bind (name . thing) fun
+ (declare (ignore name))
+ (etypecase thing
+ (functional nil)
+ (global-var t)
+ (cons (aver (eq (car thing) 'macro))
+ t))))
+ (var-good-p (var)
+ (destructuring-bind (name . thing) var
+ (declare (ignore name))
+ (etypecase thing
+ (leaf nil)
+ (cons (aver (eq (car thing) 'macro))
+ t)
+ (heap-alien-info nil)))))
+ (internal-make-lexenv
+ (remove-if-not #'fun-good-p (lexenv-funs lexenv))
+ (remove-if-not #'var-good-p (lexenv-vars lexenv))
+ nil
+ nil
+ (lexenv-type-restrictions lexenv) ; XXX
+ (lexenv-weakend-type-restrictions lexenv)
+ nil
+ nil
+ (lexenv-policy lexenv))))
\f
;;;; flow/DFO/component hackery
;;; Join BLOCK1 and BLOCK2.
-#!-sb-fluid (declaim (inline link-blocks))
(defun link-blocks (block1 block2)
(declare (type cblock block1 block2))
(setf (block-succ block1)
`(when (eq (,slot last) old)
(setf (,slot last) new))))
(frob if-consequent)
- (frob if-alternative))))
+ (frob if-alternative)
+ (when (eq (if-consequent last)
+ (if-alternative last))
+ (setf (component-reoptimize (block-component block)) t)))))
(t
(unless (member new (block-succ block) :test #'eq)
(link-blocks block new)))))
(values))
;;; Add BLOCK to the next/prev chain following AFTER. We also set the
-;;; Component to be the same as for AFTER.
+;;; COMPONENT to be the same as for AFTER.
(defun add-to-dfo (block after)
(declare (type cblock block after))
(let ((next (block-next after))
(defun make-empty-component ()
(let* ((head (make-block-key :start nil :component nil))
(tail (make-block-key :start nil :component nil))
- (res (make-component :head head :tail tail)))
+ (res (make-component head tail)))
(setf (block-flag head) t)
(setf (block-flag tail) t)
(setf (block-component head) res)
(link-blocks block new-block)
(add-to-dfo new-block block)
(setf (component-reanalyze (block-component block)) t)
-
+
(do ((cont start (node-cont (continuation-next cont))))
((eq cont last-cont)
(when (eq (continuation-kind last-cont) :inside-block)
\f
;;;; deleting stuff
-;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. We
-;;; 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
-;;; deleted the last variable.
-;;;
-;;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
-;;; too much difficulty, since we can efficiently implement write-only
-;;; variables. We iterate over the sets, marking their blocks for dead
-;;; code flushing, since we can delete sets whose value is unused.
+;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
(defun delete-lambda-var (leaf)
(declare (type lambda-var leaf))
+
+ ;; 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
+ ;; deleted its last variable.
(let* ((fun (lambda-var-home leaf))
(n (position leaf (lambda-vars fun))))
(dolist (ref (leaf-refs fun))
(flush-dest arg)
(setf (elt args n) nil))))))
+ ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
+ ;; too much difficulty, since we can efficiently implement
+ ;; write-only variables. We iterate over the SETs, marking their
+ ;; blocks for dead code flushing, since we can delete SETs whose
+ ;; value is unused.
(dolist (set (lambda-var-sets leaf))
(setf (block-flush-p (node-block set)) t))
(values))
-;;; Note that something interesting has happened to VAR. We only deal
-;;; with LET variables, marking the corresponding initial value arg as
-;;; needing to be reoptimized.
+;;; Note that something interesting has happened to VAR.
(defun reoptimize-lambda-var (var)
(declare (type lambda-var var))
(let ((fun (lambda-var-home var)))
+ ;; We only deal with LET variables, marking the corresponding
+ ;; initial value arg as needing to be reoptimized.
(when (and (eq (functional-kind fun) :let)
(leaf-refs var))
(do ((args (basic-combination-args
;;; DELETE-REF will handle the deletion.
(defun delete-functional (fun)
(aver (and (null (leaf-refs fun))
- (not (functional-entry-function fun))))
+ (not (functional-entry-fun fun))))
(etypecase fun
(optional-dispatch (delete-optional-dispatch fun))
(clambda (delete-lambda fun)))
(values))
-;;; Deal with deleting the last reference to a LAMBDA. Since there is
-;;; only one way into a LAMBDA, deleting the last reference to a
-;;; LAMBDA ensures that there is no way to reach any of the code in
+;;; Deal with deleting the last reference to a CLAMBDA. Since there is
+;;; only one way into a CLAMBDA, deleting the last reference to a
+;;; CLAMBDA ensures that there is no way to reach any of the code in
;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to
;;; :DELETED, causing IR1 optimization to delete blocks in that
-;;; lambda.
-;;;
-;;; If the function isn't a LET, we unlink the function head and tail
-;;; from the component head and tail to indicate that the code is
-;;; unreachable. We also delete the function from COMPONENT-LAMBDAS
-;;; (it won't be there before local call analysis, but no matter.) If
-;;; the lambda was never referenced, we give a note.
-;;;
-;;; If the lambda is an XEP, then we null out the ENTRY-FUNCTION in its
-;;; ENTRY-FUNCTION so that people will know that it is not an entry point
-;;; anymore.
-(defun delete-lambda (leaf)
- (declare (type clambda leaf))
- (let ((kind (functional-kind leaf))
- (bind (lambda-bind leaf)))
- (aver (not (member kind '(:deleted :optional :top-level))))
- (aver (not (functional-has-external-references-p leaf)))
- (setf (functional-kind leaf) :deleted)
- (setf (lambda-bind leaf) nil)
- (dolist (let (lambda-lets leaf))
+;;; CLAMBDA.
+(defun delete-lambda (clambda)
+ (declare (type clambda clambda))
+ (let ((original-kind (functional-kind clambda))
+ (bind (lambda-bind clambda)))
+ (aver (not (member original-kind '(:deleted :optional :toplevel))))
+ (aver (not (functional-has-external-references-p clambda)))
+ (setf (functional-kind clambda) :deleted)
+ (setf (lambda-bind clambda) nil)
+ (dolist (let (lambda-lets clambda))
(setf (lambda-bind let) nil)
(setf (functional-kind let) :deleted))
- (if (member kind '(:let :mv-let :assignment))
- (let ((home (lambda-home leaf)))
- (setf (lambda-lets home) (delete leaf (lambda-lets home))))
+ ;; LET may be deleted if its BIND is unreachable. Autonomous
+ ;; function may be deleted if it has no reachable references.
+ (unless (member original-kind '(:let :mv-let :assignment))
+ (dolist (ref (lambda-refs clambda))
+ (mark-for-deletion (node-block ref))))
+
+ ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
+ ;; that we're using the old value of the KIND slot, not the
+ ;; current slot value, which has now been set to :DELETED.)
+ (if (member original-kind '(:let :mv-let :assignment))
+ (let ((home (lambda-home clambda)))
+ (setf (lambda-lets home) (delete clambda (lambda-lets home))))
+ ;; If the function isn't a LET, we unlink the function head
+ ;; and tail from the component head and tail to indicate that
+ ;; the code is unreachable. We also delete the function from
+ ;; COMPONENT-LAMBDAS (it won't be there before local call
+ ;; analysis, but no matter.) If the lambda was never
+ ;; referenced, we give a note.
(let* ((bind-block (node-block bind))
(component (block-component bind-block))
- (return (lambda-return leaf)))
- (aver (null (leaf-refs leaf)))
- (unless (leaf-ever-used leaf)
+ (return (lambda-return clambda))
+ (return-block (and return (node-block return))))
+ (unless (leaf-ever-used clambda)
(let ((*compiler-error-context* bind))
(compiler-note "deleting unused function~:[.~;~:*~% ~S~]"
- (leaf-name leaf))))
- (unlink-blocks (component-head component) bind-block)
- (when return
- (unlink-blocks (node-block return) (component-tail component)))
+ (leaf-debug-name clambda))))
+ (unless (block-delete-p bind-block)
+ (unlink-blocks (component-head component) bind-block))
+ (when (and return-block (not (block-delete-p return-block)))
+ (mark-for-deletion return-block)
+ (unlink-blocks return-block (component-tail component)))
(setf (component-reanalyze component) t)
- (let ((tails (lambda-tail-set leaf)))
- (setf (tail-set-functions tails)
- (delete leaf (tail-set-functions tails)))
- (setf (lambda-tail-set leaf) nil))
+ (let ((tails (lambda-tail-set clambda)))
+ (setf (tail-set-funs tails)
+ (delete clambda (tail-set-funs tails)))
+ (setf (lambda-tail-set clambda) nil))
(setf (component-lambdas component)
- (delete leaf (component-lambdas component)))))
-
- (when (eq kind :external)
- (let ((fun (functional-entry-function leaf)))
- (setf (functional-entry-function fun) nil)
+ (delete clambda (component-lambdas component)))))
+
+ ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
+ ;; ENTRY-FUN so that people will know that it is not an entry
+ ;; point anymore.
+ (when (eq original-kind :external)
+ (let ((fun (functional-entry-fun clambda)))
+ (setf (functional-entry-fun fun) nil)
(when (optional-dispatch-p fun)
(delete-optional-dispatch fun)))))
;;; entry-points, making them be normal lambdas, and then deleting the
;;; ones with no references. This deletes any e-p lambdas that were
;;; either never referenced, or couldn't be deleted when the last
-;;; deference was deleted (due to their :OPTIONAL kind.)
+;;; reference was deleted (due to their :OPTIONAL kind.)
;;;
-;;; Note that the last optional ep may alias the main entry, so when
-;;; we process the main entry, its kind may have been changed to NIL
-;;; or even converted to a let.
+;;; Note that the last optional entry point may alias the main entry,
+;;; so when we process the main entry, its KIND may have been changed
+;;; to NIL or even converted to a LETlike value.
(defun delete-optional-dispatch (leaf)
(declare (type optional-dispatch leaf))
- (let ((entry (functional-entry-function leaf)))
+ (let ((entry (functional-entry-fun leaf)))
(unless (and entry (leaf-refs entry))
(aver (or (not entry) (eq (functional-kind entry) :deleted)))
(setf (functional-kind leaf) :deleted)
(cond ((null refs)
(typecase leaf
- (lambda-var (delete-lambda-var leaf))
+ (lambda-var
+ (delete-lambda-var leaf))
(clambda
(ecase (functional-kind leaf)
((nil :let :mv-let :assignment :escape :cleanup)
- (aver (not (functional-entry-function leaf)))
+ (aver (null (functional-entry-fun leaf)))
(delete-lambda leaf))
(:external
(delete-lambda leaf))
;;; containing uses of CONT and set COMPONENT-REOPTIMIZE. If the PREV
;;; of the use is deleted, then we blow off reoptimization.
;;;
-;;; If the continuation is :Deleted, then we don't do anything, since
+;;; If the continuation is :DELETED, then we don't do anything, since
;;; all semantics have already been flushed. :DELETED-BLOCK-START
;;; start continuations are treated just like :BLOCK-START; it is
;;; possible that the continuation may be given a new dest (e.g. by
(unless (eq (continuation-kind cont) :deleted)
(aver (continuation-dest cont))
(setf (continuation-dest cont) nil)
+ (setf (continuation-%externally-checkable-type cont) nil)
(do-uses (use cont)
(let ((prev (node-prev use)))
(unless (eq (continuation-kind prev) :deleted)
;;; blocks with the DELETE-P flag.
(defun mark-for-deletion (block)
(declare (type cblock block))
- (unless (block-delete-p block)
- (setf (block-delete-p block) t)
- (setf (component-reanalyze (block-component block)) t)
- (dolist (pred (block-pred block))
- (mark-for-deletion pred)))
+ (let* ((component (block-component block))
+ (head (component-head component)))
+ (labels ((helper (block)
+ (setf (block-delete-p block) t)
+ (dolist (pred (block-pred block))
+ (unless (or (block-delete-p pred)
+ (eq pred head))
+ (helper pred)))))
+ (unless (block-delete-p block)
+ (helper block)
+ (setf (component-reanalyze component) t))))
(values))
;;; Delete CONT, eliminating both control and value semantics. We set
(setf (continuation-kind cont) :deleted)
(setf (continuation-dest cont) nil)
+ (setf (continuation-%externally-checkable-type cont) nil)
(setf (continuation-next cont) nil)
(setf (continuation-asserted-type cont) *empty-type*)
(setf (continuation-%derived-type cont) *empty-type*)
+ (setf (continuation-type-to-check cont) *empty-type*)
(setf (continuation-use cont) nil)
(setf (continuation-block cont) nil)
(setf (continuation-reoptimize cont) nil)
(reoptimize-continuation cont)))
(dolist (b (block-pred block))
- (unlink-blocks b block))
+ (unlink-blocks b block)
+ ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
+ ;; broken when successors were deleted without setting the
+ ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
+ ;; doesn't happen again.
+ (aver (not (and (null (block-succ b))
+ (not (block-delete-p b))
+ (not (eq b (component-head (block-component b))))))))
(dolist (b (block-succ block))
(unlink-blocks block b))
;; Guards COMBINATION-LAMBDA agains the REF being deleted.
(continuation-use (basic-combination-fun node)))
(let ((fun (combination-lambda node)))
- ;; If our REF was the 2'nd to last ref, and has been deleted, then
- ;; Fun may be a LET for some other combination.
- (when (and (member (functional-kind fun) '(:let :mv-let))
+ ;; If our REF was the second-to-last ref, and has been
+ ;; deleted, then FUN may be a LET for some other
+ ;; combination.
+ (when (and (functional-letlike-p fun)
(eq (let-combination fun) node))
(delete-lambda fun))))
(flush-dest (basic-combination-fun node))
(bind
(let ((lambda (bind-lambda node)))
(unless (eq (functional-kind lambda) :deleted)
- (aver (member (functional-kind lambda) '(:let :mv-let :assignment)))
(delete-lambda lambda))))
(exit
(let ((value (exit-value node))
(remove-from-dfo block)
(values))
-;;; Do stuff to indicate that the return node Node is being deleted.
-;;; We set the RETURN to NIL.
+;;; Do stuff to indicate that the return node NODE is being deleted.
(defun delete-return (node)
(declare (type creturn node))
- (let ((fun (return-lambda node)))
+ (let* ((fun (return-lambda node))
+ (tail-set (lambda-tail-set fun)))
(aver (lambda-return fun))
- (setf (lambda-return fun) nil))
+ (setf (lambda-return fun) nil)
+ (when (and tail-set (not (find-if #'lambda-return (tail-set-funs tail-set))))
+ (setf (tail-set-type tail-set) *empty-type*)))
(values))
;;; If any of the VARS in FUN was never referenced and was not
(let ((*compiler-error-context* (lambda-bind fun)))
(unless (policy *compiler-error-context* (= inhibit-warnings 3))
;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
- ;; requires this to be a STYLE-WARNING.
- (compiler-style-warning "The variable ~S is defined but never used."
- (leaf-name var)))
- (setf (leaf-ever-used var) t))))
+ ;; requires this to be no more than a STYLE-WARNING.
+ (compiler-style-warn "The variable ~S is defined but never used."
+ (leaf-debug-name var)))
+ (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
(values))
(defvar *deletion-ignored-objects* '(t nil))
(not (eq pkg (symbol-package :end))))))
(not (member first *deletion-ignored-objects*))
(not (typep first '(or fixnum character)))
- (every #'(lambda (x)
- (present-in-form first x 0))
+ (every (lambda (x)
+ (present-in-form first x 0))
(source-path-forms path))
(present-in-form first (find-original-source path)
0)))
(setf (continuation-next prev) nil))
(t
(setf (continuation-next prev) next)
- (setf (node-prev next) prev)))
+ (setf (node-prev next) prev)
+ (when (and (if-p next) ; AOP wanted
+ (eq prev (if-test next)))
+ (reoptimize-continuation prev))))
(setf (node-prev node) nil)
nil)
(t
(aver (and succ (null (cdr succ))))
(cond
((member block succ)
- (with-ir1-environment node
+ (with-ir1-environment-from-node node
(let ((exit (make-exit))
(dummy (make-continuation)))
(setf (continuation-next prev) nil)
- (prev-link exit prev)
+ (link-node-to-previous-continuation exit prev)
(add-continuation-use exit dummy)
(setf (block-last block) exit)))
(setf (node-prev node) nil)
(not (block-delete-p block))))))))
;;; Delete all the blocks and functions in COMPONENT. We scan first
-;;; marking the blocks as delete-p to prevent weird stuff from being
+;;; marking the blocks as DELETE-P to prevent weird stuff from being
;;; triggered by deletion.
(defun delete-component (component)
(declare (type component component))
- (aver (null (component-new-functions component)))
+ (aver (null (component-new-functionals component)))
(setf (component-kind component) :deleted)
(do-blocks (block component)
(setf (block-delete-p block) t))
(dolist (fun (component-lambdas component))
(setf (functional-kind fun) nil)
- (setf (functional-entry-function fun) nil)
+ (setf (functional-entry-fun fun) nil)
(setf (leaf-refs fun) nil)
(delete-functional fun))
(do-blocks (block component)
;;; of arguments changes, the transform must be prepared to return a
;;; lambda with a new lambda-list with the correct number of
;;; arguments.
-(defun extract-function-args (cont fun num-args)
+(defun extract-fun-args (cont fun num-args)
#!+sb-doc
"If CONT is a call to FUN with NUM-ARGS args, change those arguments
to feed directly to the continuation-dest of CONT, which must be
(unless (combination-p inside)
(give-up-ir1-transform))
(let ((inside-fun (combination-fun inside)))
- (unless (eq (continuation-function-name inside-fun) fun)
+ (unless (eq (continuation-fun-name inside-fun) fun)
(give-up-ir1-transform))
(let ((inside-args (combination-args inside)))
(unless (= (length inside-args) num-args)
(before-args (subseq outside-args 0 arg-position))
(after-args (subseq outside-args (1+ arg-position))))
(dolist (arg inside-args)
- (setf (continuation-dest arg) outside))
+ (setf (continuation-dest arg) outside)
+ (setf (continuation-%externally-checkable-type arg) nil))
(setf (combination-args inside) nil)
(setf (combination-args outside)
(append before-args inside-args after-args))
(change-ref-leaf (continuation-use inside-fun)
- (find-free-function 'list "???"))
- (setf (combination-kind inside) :full)
+ (find-free-fun 'list "???"))
+ (setf (combination-kind inside)
+ (info :function :info 'list))
(setf (node-derived-type inside) *wild-type*)
(flush-dest cont)
(setf (continuation-asserted-type cont) *wild-type*)
+ (setf (continuation-type-to-check cont) *wild-type*)
(values))))))
+
+(defun flush-combination (combination)
+ (declare (type combination combination))
+ (flush-dest (combination-fun combination))
+ (dolist (arg (combination-args combination))
+ (flush-dest arg))
+ (unlink-node combination)
+ (values))
+
\f
;;;; leaf hackery
-;;; Change the Leaf that a Ref refers to.
+;;; Change the LEAF that a REF refers to.
(defun change-ref-leaf (ref leaf)
(declare (type ref ref) (type leaf leaf))
(unless (eq (ref-leaf ref) leaf)
(push ref (leaf-refs leaf))
(delete-ref ref)
(setf (ref-leaf ref) leaf)
+ (setf (leaf-ever-used leaf) t)
(let ((ltype (leaf-type leaf)))
- (if (function-type-p ltype)
+ (if (let* ((cont (node-cont ref))
+ (dest (continuation-dest cont)))
+ (and (basic-combination-p dest)
+ (eq cont (basic-combination-fun dest))))
(setf (node-derived-type ref) ltype)
(derive-node-type ref ltype)))
(reoptimize-continuation (node-cont ref)))
(change-ref-leaf ref new-leaf))
(values))
-;;; Like SUBSITUTE-LEAF, only there is a predicate on the Ref to tell
-;;; whether to substitute.
+;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
+;;; whether to substitute
(defun substitute-leaf-if (test new-leaf old-leaf)
(declare (type leaf new-leaf old-leaf) (type function test))
(dolist (ref (leaf-refs old-leaf))
;;; 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.
-#!-sb-fluid (declaim (maybe-inline find-constant))
(defun find-constant (object)
- (if (typep object '(or symbol number character instance))
- (or (gethash object *constants*)
- (setf (gethash object *constants*)
- (make-constant :value object
- :name nil
- :type (ctype-of object)
- :where-from :defined)))
- (make-constant :value object
- :name nil
- :type (ctype-of object)
- :where-from :defined)))
+ (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)))
\f
+;;; 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
+;;; home lambda than VAR's home.)
+(defun closure-var-p (var)
+ (declare (type lambda-var var))
+ (let ((home (lambda-var-home var)))
+ (cond ((eq (functional-kind home) :deleted)
+ nil)
+ (t (let ((home (lambda-home home)))
+ (flet ((frob (l)
+ (find home l :key #'node-home-lambda
+ :test-not #'eq)))
+ (or (frob (leaf-refs var))
+ (frob (basic-var-sets var)))))))))
+
;;; If there is a non-local exit noted in ENTRY's environment that
;;; exits to CONT in that entry, then return it, otherwise return NIL.
(defun find-nlx-info (entry cont)
(declare (type entry entry) (type continuation cont))
(let ((entry-cleanup (entry-cleanup entry)))
- (dolist (nlx (environment-nlx-info (node-environment entry)) nil)
+ (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
(when (and (eq (nlx-info-continuation nlx) cont)
(eq (nlx-info-cleanup nlx) entry-cleanup))
(return nlx)))))
(t
(return nil)))))))
-;;; Return true if function is an XEP. This is true of normal XEPs
-;;; (:EXTERNAL kind) and top-level lambdas (:TOP-LEVEL kind.)
-(defun external-entry-point-p (fun)
+;;; Return true if function is an external entry point. This is true
+;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
+;;; (:TOPLEVEL kind.)
+(defun xep-p (fun)
(declare (type functional fun))
- (not (null (member (functional-kind fun) '(:external :top-level)))))
+ (not (null (member (functional-kind fun) '(:external :toplevel)))))
;;; If CONT's only use is a non-notinline global function reference,
;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
;;; is true, then we don't care if the leaf is NOTINLINE.
-(defun continuation-function-name (cont &optional notinline-ok)
+(defun continuation-fun-name (cont &optional notinline-ok)
(declare (type continuation cont))
(let ((use (continuation-use cont)))
(if (ref-p use)
(let ((leaf (ref-leaf use)))
(if (and (global-var-p leaf)
(eq (global-var-kind leaf) :global-function)
- (or (not (defined-function-p leaf))
- (not (eq (defined-function-inlinep leaf) :notinline))
+ (or (not (defined-fun-p leaf))
+ (not (eq (defined-fun-inlinep leaf) :notinline))
notinline-ok))
- (leaf-name leaf)
+ (leaf-source-name leaf)
nil))
nil)))
+;;; 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 (continuation-use (combination-fun combination))))
+ (leaf-source-name (ref-leaf ref))))
+
;;; Return the COMBINATION node that is the call to the LET FUN.
(defun let-combination (fun)
(declare (type clambda fun))
- (aver (member (functional-kind fun) '(:let :mv-let)))
+ (aver (functional-letlike-p fun))
(continuation-dest (node-cont (first (leaf-refs fun)))))
;;; Return the initial value continuation for a LET variable, or NIL
(elt (combination-args (let-combination fun))
(position-or-lose var (lambda-vars fun)))))
-;;; Return the LAMBDA that is called by the local Call.
-#!-sb-fluid (declaim (inline combination-lambda))
+;;; Return the LAMBDA that is called by the local CALL.
(defun combination-lambda (call)
(declare (type basic-combination call))
(aver (eq (basic-combination-kind call) :local))
;; compiler to be able to use WITH-COMPILATION-UNIT on
;; arbitrarily huge blocks of code. -- WHN)
(let ((*compiler-error-context* node))
- (compiler-note "*INLINE-EXPANSION-LIMIT* (~D) was exceeded, ~
+ (compiler-note "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
probably trying to~% ~
inline a recursive function."
*inline-expansion-limit*))
;;; Apply a function to some arguments, returning a list of the values
;;; resulting of the evaluation. If an error is signalled during the
-;;; application, then we print a warning message and return NIL as our
-;;; second value to indicate this. Node is used as the error context
-;;; for any error message, and Context is a string that is spliced
-;;; into the warning.
-(declaim (ftype (function ((or symbol function) list node string)
+;;; application, then we produce a warning message using WARN-FUN and
+;;; return NIL as our second value to indicate this. NODE is used as
+;;; the error context for any error message, and CONTEXT is a string
+;;; that is spliced into the warning.
+(declaim (ftype (function ((or symbol function) list node function string)
(values list boolean))
careful-call))
-(defun careful-call (function args node context)
+(defun careful-call (function args node warn-fun context)
(values
(multiple-value-list
(handler-case (apply function args)
(error (condition)
(let ((*compiler-error-context* node))
- (compiler-warning "Lisp error during ~A:~%~A" context condition)
+ (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
(return-from careful-call (values nil nil))))))
t))
+
+;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
+;;; specifiers.
+(macrolet
+ ((deffrob (basic careful compiler transform)
+ `(progn
+ (defun ,careful (specifier)
+ (handler-case (,basic specifier)
+ (simple-error (condition)
+ (values nil (list* (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition))))))
+ (defun ,compiler (specifier)
+ (multiple-value-bind (type error-args) (,careful specifier)
+ (or type
+ (apply #'compiler-error error-args))))
+ (defun ,transform (specifier)
+ (multiple-value-bind (type error-args) (,careful specifier)
+ (or type
+ (apply #'give-up-ir1-transform
+ error-args)))))))
+ (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type)
+ (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type))
+
\f
;;;; utilities used at run-time for parsing &KEY args in IR1