(declare (type cblock block1 block2) (type node node)
(type (or cleanup null) cleanup))
(setf (component-reanalyze (block-component block1)) t)
- (with-ir1-environment node
+ (with-ir1-environment-from-node node
(let* ((start (make-continuation))
(block (continuation-starts-block start))
(cont (make-continuation))
;;; 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.
-(declaim (maybe-inline node-home-lambda))
(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-physenv))
(defun node-block (node)
(declare (type node node))
(the cblock (continuation-block (node-prev 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 physenv (lambda-physenv (node-home-lambda node))))
-#!-sb-fluid (declaim (maybe-inline lambda-block))
(defun lambda-block (clambda)
(declare (type clambda clambda))
(node-block (lambda-bind clambda)))
(defun lambda-component (clambda)
- (declare (inline lambda-block))
(block-component (lambda-block clambda)))
;;; Return the enclosing cleanup for environment of the first or last
(declare (type cblock block))
(node-enclosing-cleanup (block-last block)))
-;;; Return the non-LET LAMBDA that holds BLOCK's code.
-(defun block-home-lambda (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))
- #!-sb-fluid (declare (inline node-home-lambda))
(if (node-p (block-last block))
;; This is the old CMU CL way of doing it.
(node-home-lambda (block-last block))
- ;; The CMU CL approach sometimes fails, e.g. in IR1-CONVERT of
- ;; one of the legs of an IF, now that SBCL uses this operation
- ;; more aggressively than CMU CL did.
- ;;
- ;; In this case 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. We could
- ;; get fancy about this, flooding 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 (block-pred 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)
+ (the clambda
+ (block-home-lambda-or-null block)))
;;; Return the IR1 physical environment for BLOCK.
(defun block-physenv (block)
(declare (type cblock block))
- #!-sb-fluid (declare (inline node-home-lambda))
(lambda-physenv (block-home-lambda block)))
;;; Return the Top Level Form number of PATH, i.e. the ordinal number
(values (node-source-form use) t)
(values nil nil))))
-;;; Return the LAMBDA that is CONT's home.
-(defun continuation-home-lambda (cont)
+;;; 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 works; then if that
+ ;; NODE-HOME-LAMBDA of CONTINUATION-USE usually work; then if that
;; fails, BLOCK-HOME-LAMBDA of CONTINUATION-BLOCK works, given that
- ;; generalize it enough to grovel harder when the simple CMU CL
- ;; approach fails. -- WHN 2001-12-02
+ ;; 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 (continuation-block cont)))
+ (block-home-lambda-or-null (continuation-block cont)))
(t
- (error "internal error: can't find home lambda for ~S"))))
+ (error "internal error: 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)))
\f
;;; Return a new LEXENV just like DEFAULT except for the specified
;;; slot values. Values for the alist slots are NCONCed to the
;;;; 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)
(unless (policy *compiler-error-context* (= inhibit-warnings 3))
;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
;; requires this to be no more than a STYLE-WARNING.
- (compiler-style-warning "The variable ~S is defined but never used."
- (leaf-debug-name var)))
+ (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))
(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)))
(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))
(t
(return nil)))))))
-;;; Return true if function is an XEP. This is true of normal XEPs
-;;; (:EXTERNAL kind) and top level lambdas (:TOPLEVEL 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 :toplevel)))))
(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*))
(handler-case (apply function args)
(error (condition)
(let ((*compiler-error-context* node))
- (compiler-warning "Lisp error during ~A:~%~A" context condition)
+ (compiler-warn "Lisp error during ~A:~%~A" context condition)
(return-from careful-call (values nil nil))))))
t))
\f