X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1opt.lisp;h=ff7fb3ad176aec640a89507aa8fc341628974578;hb=90ca09b75fbc3b63b2f7d09c67b04b866dd783f6;hp=a38f2fb6e596265dbb06da7196b744bad92be26a;hpb=be9eb6c67b5f43a095c3de17bea945c309d662e4;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index a38f2fb..ff7fb3a 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -497,7 +497,7 @@
 (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)))
@@ -509,7 +509,7 @@
 
       (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)))))))
 
@@ -687,8 +687,8 @@
 		    ;; 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)))
 
@@ -705,7 +705,7 @@
 	     #!+sb-show 
 	     (when *show-transforms-p*
 	       (let* ((cont (basic-combination-fun node))
-		      (fname (continuation-function-name cont t)))
+		      (fname (continuation-fun-name cont t)))
 		 (/show "trying transform" x (transform-function x) "for" fname)))
 	     (unless (ir1-transform node x)
 	       #!+sb-show
@@ -767,7 +767,7 @@
 ;;; 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
@@ -788,8 +788,8 @@
   (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))
@@ -800,34 +800,38 @@
 	     (: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
 	      (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)))))))
@@ -875,7 +879,7 @@
 	 (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
@@ -900,19 +904,30 @@
 		 (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))
 
 ;;;; known function optimization
@@ -1069,17 +1084,19 @@
 (defun transform-call (node res)
   (declare (type combination node) (list res))
   (with-ir1-environment node
-    (let ((new-fun (ir1-convert-inline-lambda res))
+    (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.
@@ -1090,10 +1107,10 @@
   (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))))
@@ -1158,12 +1175,11 @@
       ((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.
@@ -1226,7 +1242,7 @@
 ;;; 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
@@ -1235,7 +1251,7 @@
 ;;;
 ;;; 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.
 ;;;
@@ -1243,7 +1259,7 @@
 ;;; 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)
@@ -1267,8 +1283,7 @@
 				  this-comp)
 			      t)
 			     (t
-			      (aver (eq (functional-kind (lambda-home fun))
-					:top-level))
+			      (aver (lambda-toplevelish-p (lambda-home fun)))
 			      nil)))
 		   leaf var))
 		t)))))
@@ -1297,7 +1312,7 @@
 (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)
@@ -1372,7 +1387,7 @@
 	     (when (eq (basic-combination-kind node) :local)
 	       (maybe-let-convert (ref-leaf use))))))
        (unless (or (eq (basic-combination-kind node) :local)
-		   (eq (continuation-function-name fun) '%throw))
+		   (eq (continuation-fun-name fun) '%throw))
 	 (ir1-optimize-mv-call node))
        (dolist (arg args)
 	 (setf (continuation-reoptimize arg) nil))))
@@ -1475,7 +1490,7 @@
 			      (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))
 
@@ -1499,7 +1514,7 @@
   (let* ((arg (first (basic-combination-args call)))
 	 (use (continuation-use arg)))
     (when (and (combination-p use)
-	       (eq (continuation-function-name (combination-fun use))
+	       (eq (continuation-fun-name (combination-fun use))
 		   'values))
       (let* ((fun (combination-lambda call))
 	     (vars (lambda-vars fun))
@@ -1549,7 +1564,7 @@
 (defoptimizer (values-list optimizer) ((list) node)
   (let ((use (continuation-use list)))
     (when (and (combination-p use)
-	       (eq (continuation-function-name (combination-fun use))
+	       (eq (continuation-fun-name (combination-fun use))
 		   'list))
       (change-ref-leaf (continuation-use (combination-fun node))
 		       (find-free-function 'values "in a strange place"))