X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=a721dee6ad0796cab61e376618995a6326ae176f;hb=5ecef987f3847ed5de8c03f66ef9d8ab468af993;hp=501aaf6ed08bad3442c4b7869976103a46dcdc5a;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index 501aaf6..a721dee 100644
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -58,7 +58,7 @@
     ((:safe :fast-safe) t)
     ((:small :fast) nil)))
 
-;;; an annotated continuation's primitive-type
+;;; an annotated lvar's primitive-type
 #!-sb-fluid (declaim (inline lvar-ptype))
 (defun lvar-ptype (lvar)
   (declare (type lvar lvar))
@@ -98,8 +98,12 @@
     (cond
      ((lvar-delayed-leaf lvar)
       (setf (ir2-lvar-kind info) :delayed))
-     (t (setf (ir2-lvar-locs info)
-              (list (make-normal-tn (ir2-lvar-primitive-type info)))))))
+     (t (let ((tn (make-normal-tn (ir2-lvar-primitive-type info))))
+          (setf (ir2-lvar-locs info) (list tn))
+          #!+stack-grows-downward-not-upward
+          (when (lvar-dynamic-extent lvar)
+            (setf (ir2-lvar-stack-pointer info)
+                  (make-stack-pointer-tn)))))))
   (ltn-annotate-casts lvar)
   (values))
 
@@ -118,6 +122,7 @@
 ;;; reference, otherwise we annotate for a single value.
 (defun annotate-fun-lvar (lvar &optional (delay t))
   (declare (type lvar lvar))
+  (aver (not (lvar-dynamic-extent lvar)))
   (let* ((tn-ptype (primitive-type (lvar-type lvar)))
 	 (info (make-ir2-lvar tn-ptype)))
     (setf (lvar-info lvar) info)
@@ -159,7 +164,8 @@
 ;;; can bail out to here.
 (defun ltn-default-call (call)
   (declare (type combination call))
-  (let ((kind (basic-combination-kind call)))
+  (let ((kind (basic-combination-kind call))
+	(info (basic-combination-fun-info call)))
     (annotate-fun-lvar (basic-combination-fun call))
 
     (dolist (arg (basic-combination-args call))
@@ -169,8 +175,9 @@
       (annotate-1-value-lvar arg))
 
     (cond
-      ((and (fun-info-p kind)
-            (fun-info-ir2-convert kind))
+      ((and (eq kind :known)
+	    (fun-info-p info)
+            (fun-info-ir2-convert info))
        (setf (basic-combination-info call) :funny)
        (setf (node-tail-p call) nil))
       (t
@@ -193,6 +200,7 @@
 (defun annotate-unknown-values-lvar (lvar)
   (declare (type lvar lvar))
 
+  (aver (not (lvar-dynamic-extent lvar)))
   (let ((2lvar (make-ir2-lvar nil)))
     (setf (ir2-lvar-kind 2lvar) :unknown)
     (setf (ir2-lvar-locs 2lvar) (make-unknown-values-locations))
@@ -217,9 +225,14 @@
 ;;; specified primitive TYPES.
 (defun annotate-fixed-values-lvar (lvar types)
   (declare (type lvar lvar) (list types))
-  (let ((res (make-ir2-lvar nil)))
-    (setf (ir2-lvar-locs res) (mapcar #'make-normal-tn types))
-    (setf (lvar-info lvar) res))
+  (let ((info (make-ir2-lvar nil)))
+    (setf (ir2-lvar-locs info) (mapcar #'make-normal-tn types))
+    (setf (lvar-info lvar) info)
+    (when (lvar-dynamic-extent lvar)
+      (aver (proper-list-of-length-p types 1))
+      #!+stack-grows-downward-not-upward
+      (setf (ir2-lvar-stack-pointer info)
+            (make-stack-pointer-tn))))
   (ltn-annotate-casts lvar)
   (values))
 
@@ -311,8 +324,7 @@
 	   (setf (node-tail-p call) nil))
 	  (t
 	   (setf (basic-combination-info call) :full)
-	   (annotate-fun-lvar (basic-combination-fun call)
-				      nil)
+	   (annotate-fun-lvar (basic-combination-fun call) nil)
 	   (dolist (arg (reverse args))
 	     (annotate-unknown-values-lvar arg))
 	   (flush-full-call-tail-transfer call))))
@@ -394,6 +406,17 @@
   ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
   (setf (basic-combination-info node) :funny)
   (setf (node-tail-p node) nil))
+
+;;; Make sure that arguments of magic functions are not annotated.
+;;; (Otherwise the compiler may dump its internal structures as
+;;; constants :-()
+(defoptimizer (%pop-values ltn-annotate) ((%lvar) node ltn-policy)
+  %lvar node ltn-policy)
+(defoptimizer (%nip-values ltn-annotate) ((last-nipped last-preserved
+                                                       &rest moved)
+                                          node ltn-policy)
+  last-nipped last-preserved moved node ltn-policy)
+
 
 ;;;; known call annotation
 
@@ -401,7 +424,7 @@
 ;;; T restriction allows any operand type. This is also called by IR2
 ;;; translation when it determines whether a result temporary needs to
 ;;; be made, and by representation selection when it is deciding which
-;;; move VOP to use. CONT and TN are used to test for constant
+;;; move VOP to use. LVAR and TN are used to test for constant
 ;;; arguments.
 (defun operand-restriction-ok (restr type &key lvar tn (t-ok t))
   (declare (type (or (member *) cons) restr)
@@ -432,6 +455,7 @@
 (defun template-args-ok (template call safe-p)
   (declare (type template template)
 	   (type combination call))
+  (declare (ignore safe-p))
   (let ((mtype (template-more-args-type template)))
     (do ((args (basic-combination-args call) (cdr args))
 	 (types (template-arg-types template) (cdr types)))
@@ -492,7 +516,7 @@
 ;;;    destination of the value is an immediately following IF node.
 ;;; -- If either the template is safe or the policy is unsafe (i.e. we
 ;;;    can believe output assertions), then we test against the
-;;;    intersection of the node derived type and the continuation
+;;;    intersection of the node derived type and the lvar
 ;;;    asserted type. Otherwise, we just use the node type. If
 ;;;    TYPE-CHECK is null, there is no point in doing the intersection,
 ;;;    since the node type must be a subtype of the  assertion.
@@ -566,7 +590,7 @@
   (declare (type combination call)
 	   (type ltn-policy ltn-policy))
   (let ((safe-p (ltn-policy-safe-p ltn-policy))
-	(current (fun-info-templates (basic-combination-kind call)))
+	(current (fun-info-templates (basic-combination-fun-info call)))
 	(fallback nil)
 	(rejected nil))
     (loop
@@ -670,12 +694,18 @@
 			(or template
 			    (template-or-lose 'call-named)))
 		       *efficiency-note-cost-threshold*)))
-      (dolist (try (fun-info-templates (basic-combination-kind call)))
+      (dolist (try (fun-info-templates (basic-combination-fun-info 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))
 		     (or (not safe-p)
 			 (ltn-policy-safe-p (template-ltn-policy try)))
+                     ;; :SAFE is also considered to be :SMALL-SAFE,
+                     ;; while the template cost describes time cost;
+                     ;; so the fact that (< (t-cost try) (t-cost
+                     ;; template)) does not mean that TRY is better
+                     (not (and (eq ltn-policy :safe)
+                               (eq (template-ltn-policy try) :fast-safe)))
 		     (or verbose-p
 			 (and (template-note try)
 			      (valid-fun-use
@@ -687,13 +717,13 @@
 
     (when (losers)
       (collect ((messages)
-		(count 0 +))
+		(notes 0 +))
 	(flet ((lose1 (string &rest stuff)
 		 (messages string)
 		 (messages stuff)))
 	  (dolist (loser (losers))
 	    (when (and *efficiency-note-limit*
-		       (>= (count) *efficiency-note-limit*))
+		       (>= (notes) *efficiency-note-limit*))
 	      (lose1 "etc.")
 	      (return))
 	    (let* ((type (template-type loser))
@@ -712,7 +742,7 @@
 	       (t
 		(aver (ltn-policy-safe-p ltn-policy))
 		(lose1 "can't trust output type assertion under safe policy")))
-	      (count 1))))
+	      (notes 1))))
 
 	(let ((*compiler-error-context* call))
 	  (compiler-notify "~{~?~^~&~6T~}"
@@ -734,7 +764,7 @@
 (defun ltn-analyze-known-call (call)
   (declare (type combination call))
   (let ((ltn-policy (node-ltn-policy call))
-        (method (fun-info-ltn-annotate (basic-combination-kind call)))
+        (method (fun-info-ltn-annotate (basic-combination-fun-info call)))
 	(args (basic-combination-args call)))
     (when method
       (funcall method call ltn-policy)
@@ -762,7 +792,7 @@
 		(and (leaf-has-source-name-p funleaf)
 		     (eq (lvar-fun-name (combination-fun call))
 			 (leaf-source-name funleaf))
-		     (let ((info (basic-combination-kind call)))
+		     (let ((info (basic-combination-fun-info call)))
 		       (not (or (fun-info-ir2-convert info)
 				(ir1-attributep (fun-info-attributes info)
 						recursive))))))
@@ -794,7 +824,7 @@
   (when (and (cast-type-check cast)
              (not (node-lvar cast)))
     ;; FIXME
-    (bug "IR2 type checking of unused values in not implemented.")
+    (bug "IR2 type checking of unused values is not implemented.")
     )
   (values))
 
@@ -838,20 +868,13 @@
 	      (ctran-next ctran))
         (ctran (node-next node) (node-next node)))
       (nil)
-    (let* ((lvar (when (valued-node-p node)
-                   (node-lvar node)))
-           (dest (and lvar (lvar-dest lvar))))
-      (when (and (cast-p dest)
-                 (not (cast-type-check dest))
-                 (immediately-used-p lvar node))
-        (derive-node-type node (cast-asserted-type dest))))
     (etypecase node
       (ref)
       (combination
-       (case (basic-combination-kind node)
+       (ecase (basic-combination-kind node)
 	 (:local (ltn-analyze-local-call node))
 	 ((:full :error) (ltn-default-call node))
-	 (t
+	 (:known
 	  (ltn-analyze-known-call node))))
       (cif (ltn-analyze-if node))
       (creturn (ltn-analyze-return node))