X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=cf5662b6e1d4f04dc387e5e01051753e13938ab9;hb=e4d1085d9572b5ebf110093a04914725e4c583d4;hp=66d201d80a911ad1d02545b866740f7ab96fe4dc;hpb=1a6def3955b715472eb2c75b15660912b9f90173;p=sbcl.git

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index 66d201d..cf5662b 100644
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -140,7 +140,7 @@
 ;;; Unlike for an argument, we only clear the type check flag when the
 ;;; LTN-POLICY is unsafe, since the check for a valid function
 ;;; object must be done before the call.
-(defun annotate-function-continuation (cont ltn-policy &optional (delay t))
+(defun annotate-fun-continuation (cont ltn-policy &optional (delay t))
   (declare (type continuation cont) (type ltn-policy ltn-policy))
   (unless (ltn-policy-safe-p ltn-policy)
     (flush-type-check cont))
@@ -193,11 +193,11 @@
 (defun ltn-default-call (call ltn-policy)
   (declare (type combination call) (type ltn-policy ltn-policy))
   (let ((kind (basic-combination-kind call)))
-    (annotate-function-continuation (basic-combination-fun call) ltn-policy)
+    (annotate-fun-continuation (basic-combination-fun call) ltn-policy)
 
     (cond
-     ((and (function-info-p kind)
-	   (function-info-ir2-convert kind))
+     ((and (fun-info-p kind)
+	   (fun-info-ir2-convert kind))
       (setf (basic-combination-info call) :funny)
       (setf (node-tail-p call) nil)
       (dolist (arg (basic-combination-args call))
@@ -270,14 +270,14 @@
 ;;; we annotate for the number of values indicated by TYPES, but only
 ;;; use proven type information.
 (defun annotate-fixed-values-continuation (cont ltn-policy types)
-  (declare (continuation cont) (ltn-policy ltn-policy) (list types))
+  (declare (type continuation cont) (type ltn-policy ltn-policy) (list types))
   (unless (ltn-policy-safe-p ltn-policy)
     (flush-type-check cont))
   (let ((res (make-ir2-continuation nil)))
     (if (member (continuation-type-check cont) '(:deleted nil))
 	(setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
-	(let* ((proven (mapcar #'(lambda (x)
-				   (make-normal-tn (primitive-type x)))
+	(let* ((proven (mapcar (lambda (x)
+				 (make-normal-tn (primitive-type x)))
 			       (values-types
 				(continuation-proven-type cont))))
 	       (num-proven (length proven))
@@ -389,9 +389,9 @@
 	   (setf (node-tail-p call) nil))
 	  (t
 	   (setf (basic-combination-info call) :full)
-	   (annotate-function-continuation (basic-combination-fun call)
-					   ltn-policy
-					   nil)
+	   (annotate-fun-continuation (basic-combination-fun call)
+				      ltn-policy
+				      nil)
 	   (dolist (arg (reverse args))
 	     (annotate-unknown-values-continuation arg ltn-policy))
 	   (flush-full-call-tail-transfer call))))
@@ -424,7 +424,7 @@
     (node-ends-block call)
     (let ((block (node-block call)))
       (unlink-blocks block (first (block-succ block)))
-      (link-blocks block (node-block (lambda-bind callee)))))
+      (link-blocks block (lambda-block callee))))
   (values))
 
 ;;; Annotate the value continuation.
@@ -476,26 +476,6 @@
   ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
   (setf (basic-combination-info node) :funny)
   (setf (node-tail-p node) nil))
-
-;;; Both of these functions need special LTN-annotate methods, since
-;;; we only want to clear the TYPE-CHECK in unsafe policies. If we
-;;; allowed the call to be annotated as a full call, then no type
-;;; checking would be done.
-;;;
-;;; We also need a special LTN annotate method for %SLOT-SETTER so
-;;; that the function is ignored. This is because the reference to a
-;;; SETF function can't be delayed, so IR2 conversion would have
-;;; already emitted a call to FDEFINITION by the time the IR2 convert
-;;; method got control.
-(defoptimizer (%slot-accessor ltn-annotate) ((struct) node ltn-policy)
-  (setf (basic-combination-info node) :funny)
-  (setf (node-tail-p node) nil)
-  (annotate-ordinary-continuation struct ltn-policy))
-(defoptimizer (%slot-setter ltn-annotate) ((struct value) node ltn-policy)
-  (setf (basic-combination-info node) :funny)
-  (setf (node-tail-p node) nil)
-  (annotate-ordinary-continuation struct ltn-policy)
-  (annotate-ordinary-continuation value ltn-policy))
 
 ;;;; known call annotation
 
@@ -679,7 +659,7 @@
   (declare (type combination call)
 	   (type ltn-policy ltn-policy))
   (let ((safe-p (ltn-policy-safe-p ltn-policy))
-	(current (function-info-templates (basic-combination-kind call)))
+	(current (fun-info-templates (basic-combination-kind call)))
 	(fallback nil)
 	(rejected nil))
     (loop
@@ -730,18 +710,18 @@
       (:arg-types
        (funcall frob "argument types invalid")
        (funcall frob "argument primitive types:~%  ~S"
-		(mapcar #'(lambda (x)
-			    (primitive-type-name
-			     (continuation-ptype x)))
+		(mapcar (lambda (x)
+			  (primitive-type-name
+			   (continuation-ptype x)))
 			(combination-args call)))
        (funcall frob "argument type assertions:~%  ~S"
-		(mapcar #'(lambda (x)
-			    (if (atom x)
-				x
-				(ecase (car x)
-				  (:or `(:or .,(mapcar #'primitive-type-name
-						       (cdr x))))
-				  (:constant `(:constant ,(third x))))))
+		(mapcar (lambda (x)
+			  (if (atom x)
+			      x
+			      (ecase (car x)
+				(:or `(:or .,(mapcar #'primitive-type-name
+						     (cdr x))))
+				(:constant `(:constant ,(third x))))))
 			(template-arg-types template))))
       (:conditional
        (funcall frob "conditional in a non-conditional context"))
@@ -783,7 +763,7 @@
 			(or template
 			    (template-or-lose 'call-named)))
 		       *efficiency-note-cost-threshold*)))
-      (dolist (try (function-info-templates (basic-combination-kind call)))
+      (dolist (try (fun-info-templates (basic-combination-kind call)))
 	(when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner.
 	(let ((guard (template-guard try)))
 	  (when (and (or (not guard) (funcall guard))
@@ -791,7 +771,7 @@
 			 (ltn-policy-safe-p (template-ltn-policy try)))
 		     (or verbose-p
 			 (and (template-note try)
-			      (valid-function-use
+			      (valid-fun-use
 			       call (template-type try)
 			       :argument-test #'types-equal-or-intersect
 			       :result-test
@@ -801,37 +781,37 @@
     (when (losers)
       (collect ((messages)
 		(count 0 +))
-	(flet ((frob (string &rest stuff)
+	(flet ((lose1 (string &rest stuff)
 		 (messages string)
 		 (messages stuff)))
 	  (dolist (loser (losers))
 	    (when (and *efficiency-note-limit*
 		       (>= (count) *efficiency-note-limit*))
-	      (frob "etc.")
+	      (lose1 "etc.")
 	      (return))
 	    (let* ((type (template-type loser))
-		   (valid (valid-function-use call type))
-		   (strict-valid (valid-function-use call type
-						     :strict-result t)))
-	      (frob "unable to do ~A (cost ~D) because:"
-		    (or (template-note loser) (template-name loser))
-		    (template-cost loser))
+		   (valid (valid-fun-use call type))
+		   (strict-valid (valid-fun-use call type
+						:strict-result t)))
+	      (lose1 "unable to do ~A (cost ~W) because:"
+		     (or (template-note loser) (template-name loser))
+		     (template-cost loser))
 	      (cond
 	       ((and valid strict-valid)
-		(strange-template-failure loser call ltn-policy #'frob))
+		(strange-template-failure loser call ltn-policy #'lose1))
 	       ((not valid)
-		(aver (not (valid-function-use call type
-					       :error-function #'frob
-					       :warning-function #'frob))))
+		(aver (not (valid-fun-use call type
+					  :lossage-fun #'lose1
+					  :unwinnage-fun #'lose1))))
 	       (t
 		(aver (ltn-policy-safe-p ltn-policy))
-		(frob "can't trust output type assertion under safe policy")))
+		(lose1 "can't trust output type assertion under safe policy")))
 	      (count 1))))
 
 	(let ((*compiler-error-context* call))
 	  (compiler-note "~{~?~^~&~6T~}"
 			 (if template
-			     `("forced to do ~A (cost ~D)"
+			     `("forced to do ~A (cost ~W)"
 			       (,(or (template-note template)
 				     (template-name template))
 				,(template-cost template))
@@ -871,7 +851,7 @@
 (defun ltn-analyze-known-call (call ltn-policy)
   (declare (type combination call)
 	   (type ltn-policy ltn-policy))
-  (let ((method (function-info-ltn-annotate (basic-combination-kind call)))
+  (let ((method (fun-info-ltn-annotate (basic-combination-kind call)))
 	(args (basic-combination-args call)))
     (when method
       (funcall method call ltn-policy)
@@ -895,22 +875,21 @@
       ;; to implement an out-of-line version in terms of inline
       ;; transforms or VOPs or whatever.
       (unless template
-	(when (let ((funleaf (physenv-function (node-physenv call))))
+	(when (let ((funleaf (physenv-lambda (node-physenv call))))
 		(and (leaf-has-source-name-p funleaf)
 		     (eq (continuation-fun-name (combination-fun call))
 			 (leaf-source-name funleaf))
 		     (let ((info (basic-combination-kind call)))
-		       (not (or (function-info-ir2-convert info)
-				(ir1-attributep (function-info-attributes info)
+		       (not (or (fun-info-ir2-convert info)
+				(ir1-attributep (fun-info-attributes info)
 						recursive))))))
 	  (let ((*compiler-error-context* call))
-	    (compiler-warning "~@<recursion in known function definition~2I ~
-                               ~_policy=~S ~_arg types=~S~:>"
-			      (lexenv-policy (node-lexenv call))
-			      (mapcar (lambda (arg)
-					(type-specifier (continuation-type
-							 arg)))
-				      args))))
+	    (compiler-warn "~@<recursion in known function definition~2I ~
+                            ~_policy=~S ~_arg types=~S~:>"
+			   (lexenv-policy (node-lexenv call))
+			   (mapcar (lambda (arg)
+				     (type-specifier (continuation-type arg)))
+				   args))))
 	(ltn-default-call call ltn-policy)
 	(return-from ltn-analyze-known-call (values)))
       (setf (basic-combination-info call) template)