X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=4328b58883f2c9e46f8a3c3ee2734f27be40a41e;hb=90ca09b75fbc3b63b2f7d09c67b04b866dd783f6;hp=26a25a65d355c8dba1750b488d7b282caf1b84ad;hpb=984fdfe0dd7c0acfb915b11f7dba86ff3713778f;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 26a25a6..4328b58 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -203,13 +203,14 @@
     (: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)))
@@ -234,7 +235,6 @@
 ;;; 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))
@@ -244,22 +244,17 @@
     (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-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
@@ -271,17 +266,53 @@
   (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 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.
@@ -324,6 +355,29 @@
     (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
+	 (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)))
 
 ;;; Return a new LEXENV just like DEFAULT except for the specified
 ;;; slot values. Values for the alist slots are NCONCed to the
@@ -351,7 +405,6 @@
 ;;;; 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)
@@ -690,7 +743,8 @@
 
     (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)
@@ -1244,8 +1298,7 @@
     (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))
@@ -1276,7 +1329,7 @@
 	   ;; 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*))