(continuation-starts-block cont)
(link-blocks start-block then-block)
- (link-blocks start-block else-block)
+ (link-blocks start-block else-block))
- (ir1-convert then-cont cont then)
- (ir1-convert else-cont cont else))))
+ (ir1-convert then-cont cont then)
+ (ir1-convert else-cont cont else)))
\f
;;;; BLOCK and TAGBODY
-;;;; We make an Entry node to mark the start and a :Entry cleanup to
-;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit
+;;;; We make an ENTRY node to mark the start and a :ENTRY cleanup to
+;;;; mark its extent. When doing GO or RETURN-FROM, we emit an EXIT
;;;; node.
;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
(leaf
(when (constant-p leaf)
(compiler-error "~S is a constant and thus can't be set." name))
- (when (and (lambda-var-p leaf)
- (lambda-var-ignorep leaf))
- ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
- ;; requires that this be a STYLE-WARNING, not a full warning.
- (compiler-style-warning
- "~S is being set even though it was declared to be ignored."
- name))
+ (when (lambda-var-p leaf)
+ (let ((home-lambda (continuation-home-lambda start)))
+ (pushnew leaf (lambda-refers-to-vars home-lambda)))
+ (when (lambda-var-ignorep leaf)
+ ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
+ ;; requires that this be a STYLE-WARNING, not a full warning.
+ (compiler-style-warning
+ "~S is being set even though it was declared to be ignored."
+ name)))
(set-variable start cont leaf (second things)))
(cons
(aver (eq (car leaf) 'MACRO))
(let ((var (or (lexenv-find name variables) (find-free-variable name))))
(etypecase var
(leaf
- (when (and (lambda-var-p var) (lambda-var-ignorep var))
- ;; (ANSI's specification for the IGNORE declaration requires
- ;; that this be a STYLE-WARNING, not a full WARNING.)
- (compiler-style-warning "reading an ignored variable: ~S" name))
+ (when (lambda-var-p var)
+ (pushnew var
+ (lambda-refers-to-vars (continuation-home-lambda start)))
+ (when (lambda-var-ignorep var)
+ ;; (ANSI's specification for the IGNORE declaration requires
+ ;; that this be a STYLE-WARNING, not a full WARNING.)
+ (compiler-style-warning "reading an ignored variable: ~S" name)))
(reference-leaf start cont var))
(cons
(aver (eq (car var) 'MACRO))
;;;; converting combinations
;;; Convert a function call where the function (i.e. the FUN argument)
-;;; is a LEAF. We return the COMBINATION node so that we can poke at
-;;; it if we want to.
+;;; is a LEAF. We return the COMBINATION node so that the caller can
+;;; poke at it if it wants to.
(declaim (ftype (function (continuation continuation list leaf) combination)
ir1-convert-combination))
(defun ir1-convert-combination (start cont form fun)
(: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)))
(defun block-home-lambda (block)
(declare (type cblock block))
#!-sb-fluid (declare (inline node-home-lambda))
- (node-home-lambda (block-last block)))
+ (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))))))
;;; Return the IR1 physical environment for BLOCK.
(defun block-physenv (block)
(declare (type cblock block))
#!-sb-fluid (declare (inline node-home-lambda))
- (lambda-physenv (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.
(if use
(values (node-source-form use) t)
(values nil nil))))
+
+;;; Return the LAMBDA that is CONT's home.
+(defun continuation-home-lambda (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
+ ;; 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
+ (cond ((continuation-use cont)
+ (node-home-lambda (continuation-use cont)))
+ ((continuation-block cont)
+ (block-home-lambda (continuation-block cont)))
+ (t
+ (error "internal error: can't find home lambda for ~S"))))
\f
;;; Return a new LEXENV just like DEFAULT except for the specified
;;; slot values. Values for the alist slots are NCONCed to the
;; which calls things.
(setf (lambda-calls clambda) nil)
+ ;; All of CLAMBDA's variable references belong to HOME now.
+ (setf (lambda-refers-to-vars home)
+ (nunion (lambda-refers-to-vars clambda)
+ (lambda-refers-to-vars home)))
+ ;; CLAMBDA no longer has an independent existence as an entity
+ ;; which refers to things.
+ (setf (lambda-refers-to-vars clambda) nil)
+
;; All of CLAMBDA's ENTRIES belong to HOME now.
(setf (lambda-entries home)
- (nconc (lambda-entries clambda) (lambda-entries home)))
+ (nconc (lambda-entries clambda)
+ (lambda-entries home)))
;; CLAMBDA no longer has an independent existence as an entity
;; with ENTRIES.
(setf (lambda-entries clambda) nil))
;; cached type of this continuation's value. If NIL, then this must
;; be recomputed: see CONTINUATION-DERIVED-TYPE.
(%derived-type nil :type (or ctype null))
- ;; Node where this continuation is used, if unique. This is always
+ ;; the node where this continuation is used, if unique. This is always
;; null in :DELETED and :UNUSED continuations, and is never null in
;; :INSIDE-BLOCK continuations. In a :BLOCK-START continuation, the
;; Block's START-USES indicate whether NIL means no uses or more
;; (or one of its LETs) using a non-LET local call. This may include
;; deleted functions because nobody bothers to clear them out.
(calls () :type list)
+ ;; a list of all the LAMBDA-VARs directly referred to from this
+ ;; function (or one of its LETs). This may include deleted variables
+ ;; because nobody bothers to clean them out.
+ ;;
+ ;; FIXME: This is completely analogous to the CALLS slot, except the
+ ;; elements here are LAMBDA-VARs instead of FUNCTIONALs. Maybe the
+ ;; two lists should be merged into a single list.
+ (refers-to-vars () :type list)
;; the TAIL-SET that this LAMBDA is in. This is null during creation.
;;
;; In CMU CL, and old SBCL, this was also NILed out when LET
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.86.flaky7.14"
+"0.pre7.86.flaky7.16"
projects / sbcl.git / commitdiff