X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=3d06bd0aab0bee14026f92b8e9d0d7f089b7646f;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=46ab1ba8d728355a19381548cba6770ea2bafddf;hpb=c0595e94aab165f59454a3a97f06a8bdc22f5bd3;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 46ab1ba..3d06bd0 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -107,6 +107,14 @@
 
 ;;;; interface routines used by optimizers
 
+(declaim (inline reoptimize-component))
+(defun reoptimize-component (component kind)
+  (declare (type component component)
+           (type (member nil :maybe t) kind))
+  (aver kind)
+  (unless (eq (component-reoptimize component) t)
+    (setf (component-reoptimize component) kind)))
+
 ;;; This function is called by optimizers to indicate that something
 ;;; interesting has happened to the value of LVAR. Optimizers must
 ;;; make sure that they don't call for reoptimization when nothing has
@@ -130,7 +138,7 @@
           (when (typep dest 'cif)
             (setf (block-test-modified block) t))
           (setf (block-reoptimize block) t)
-          (setf (component-reoptimize component) t))))
+          (reoptimize-component component :maybe))))
     (do-uses (node lvar)
       (setf (block-type-check (node-block node)) t)))
   (values))
@@ -140,7 +148,7 @@
   (do-uses (use lvar)
     (setf (node-reoptimize use) t)
     (setf (block-reoptimize (node-block use)) t)
-    (setf (component-reoptimize (node-component use)) t)))
+    (reoptimize-component (node-component use) :maybe)))
 
 ;;; Annotate NODE to indicate that its result has been proven to be
 ;;; TYPEP to RTYPE. After IR1 conversion has happened, this is the
@@ -164,7 +172,7 @@
 	    (let ((*compiler-error-context* node))
 	      (compiler-warn
 	       "New inferred type ~S conflicts with old type:~
-		~%  ~S~%*** possible internal error? Please report this."
+                ~%  ~S~%*** possible internal error? Please report this."
 	       (type-specifier rtype) (type-specifier node-type))))
 	  (setf (node-derived-type node) int)
           ;; If the new type consists of only one object, replace the
@@ -187,24 +195,12 @@
 (defun assert-lvar-type (lvar type policy)
   (declare (type lvar lvar) (type ctype type))
   (unless (values-subtypep (lvar-derived-type lvar) type)
-    (let* ((dest (lvar-dest lvar))
-           (ctran (node-prev dest)))
-      (with-ir1-environment-from-node dest
-        (let* ((cast (make-cast lvar type policy))
-               (internal-lvar (make-lvar))
-               (internal-ctran (make-ctran)))
-          (setf (ctran-next ctran) cast
-                (node-prev cast) ctran)
-          (use-continuation cast internal-ctran internal-lvar)
-          (link-node-to-previous-ctran dest internal-ctran)
-          (substitute-lvar internal-lvar lvar)
-          (setf (lvar-dest lvar) cast)
-          (reoptimize-lvar lvar)
-          (when (return-p dest)
-            (node-ends-block cast))
-          (setf (block-attributep (block-flags (node-block cast))
-                                  type-check type-asserted)
-                t))))))
+    (let ((internal-lvar (make-lvar))
+          (dest (lvar-dest lvar)))
+      (substitute-lvar internal-lvar lvar)
+      (let ((cast (insert-cast-before dest lvar type policy)))
+        (use-lvar cast internal-lvar))))
+  (values))
 
 
 ;;;; IR1-OPTIMIZE
@@ -213,7 +209,7 @@
 ;;; and doing IR1 optimizations. We can ignore all blocks that don't
 ;;; have the REOPTIMIZE flag set. If COMPONENT-REOPTIMIZE is true when
 ;;; we are done, then another iteration would be beneficial.
-(defun ir1-optimize (component)
+(defun ir1-optimize (component fastp)
   (declare (type component component))
   (setf (component-reoptimize component) nil)
   (loop with block = (block-next (component-head component))
@@ -255,7 +251,7 @@
                  (unless (join-successor-if-possible block)
                    (return)))
 
-              (when (and (block-reoptimize block) (block-component block))
+              (when (and (not fastp) (block-reoptimize block) (block-component block))
                 (aver (not (block-delete-p block)))
                 (ir1-optimize-block block))
 
@@ -336,8 +332,16 @@
               ;; thus the control transfer is a non-local exit.
               (not (eq (block-home-lambda block)
                        (block-home-lambda next)))
-              ;; Stack analysis phase wants ENTRY to start a block.
-              (entry-p (block-start-node next)))
+              ;; Stack analysis phase wants ENTRY to start a block...
+              (entry-p (block-start-node next))
+              (let ((last (block-last block)))
+                (and (valued-node-p last)
+                     (awhen (node-lvar last)
+                       (or 
+                        ;; ... and a DX-allocator to end a block.
+                        (lvar-dynamic-extent it)
+                        ;; FIXME: This is a partial workaround for bug 303.
+                        (consp (lvar-uses it)))))))
              nil)
             (t
              (join-blocks block next)
@@ -391,8 +395,9 @@
 	 (delete-ref node)
 	 (unlink-node node))
 	(combination
-	 (let ((info (combination-kind node)))
-	   (when (fun-info-p info)
+	 (let ((kind (combination-kind node))
+	       (info (combination-fun-info node)))
+	   (when (and (eq kind :known) (fun-info-p info))
 	     (let ((attr (fun-info-attributes info)))
 	       (when (and (not (ir1-attributep attr call))
 			  ;; ### For now, don't delete potentially
@@ -639,23 +644,36 @@
     (propagate-fun-change node)
     (maybe-terminate-block node nil))
   (let ((args (basic-combination-args node))
-	(kind (basic-combination-kind node)))
-    (case kind
+	(kind (basic-combination-kind node))
+	(info (basic-combination-fun-info node)))
+    (ecase kind
       (:local
        (let ((fun (combination-lambda node)))
 	 (if (eq (functional-kind fun) :let)
 	     (propagate-let-args node fun)
 	     (propagate-local-call-args node fun))))
-      ((:full :error)
+      (:error
        (dolist (arg args)
 	 (when arg
 	   (setf (lvar-reoptimize arg) nil))))
-      (t
+      (:full
+       (dolist (arg args)
+	 (when arg
+	   (setf (lvar-reoptimize arg) nil)))
+       (when info
+	 (let ((fun (fun-info-derive-type info)))
+	   (when fun
+	     (let ((res (funcall fun node)))
+	       (when res
+		 (derive-node-type node (coerce-to-values res))
+		 (maybe-terminate-block node nil)))))))
+      (:known
+       (aver info)
        (dolist (arg args)
 	 (when arg
 	   (setf (lvar-reoptimize arg) nil)))
 
-       (let ((attr (fun-info-attributes kind)))
+       (let ((attr (fun-info-attributes info)))
 	 (when (and (ir1-attributep attr foldable)
 		    ;; KLUDGE: The next test could be made more sensitive,
 		    ;; only suppressing constant-folding of functions with
@@ -681,16 +699,16 @@
 	   (constant-fold-call node)
 	   (return-from ir1-optimize-combination)))
 
-       (let ((fun (fun-info-derive-type kind)))
+       (let ((fun (fun-info-derive-type info)))
 	 (when fun
 	   (let ((res (funcall fun node)))
 	     (when res
 	       (derive-node-type node (coerce-to-values res))
 	       (maybe-terminate-block node nil)))))
 
-       (let ((fun (fun-info-optimizer kind)))
+       (let ((fun (fun-info-optimizer info)))
 	 (unless (and fun (funcall fun node))
-	   (dolist (x (fun-info-transforms kind))
+	   (dolist (x (fun-info-transforms info))
 	     #!+sb-show
 	     (when *show-transforms-p*
 	       (let* ((lvar (basic-combination-fun node))
@@ -720,12 +738,13 @@
 ;;;
 ;;; Why do we need to consider LVAR type? -- APD, 2003-07-30
 (defun maybe-terminate-block (node ir1-converting-not-optimizing-p)
-  (declare (type (or basic-combination cast) node))
+  (declare (type (or basic-combination cast ref) node))
   (let* ((block (node-block node))
 	 (lvar (node-lvar node))
          (ctran (node-next node))
 	 (tail (component-tail (block-component block)))
 	 (succ (first (block-succ block))))
+    (declare (ignore lvar))
     (unless (or (and (eq node (block-last block)) (eq succ tail))
 		(block-delete-p block))
       (when (eq (node-derived-type node) *empty-type*)
@@ -743,13 +762,16 @@
 	      (t
 	       (node-ends-block node)))
 
-	(unlink-blocks block (first (block-succ block)))
-	(setf (component-reanalyze (block-component block)) t)
-	(aver (not (block-succ block)))
-	(link-blocks block tail)
-        (if ir1-converting-not-optimizing-p
-            (%delete-lvar-use node)
-            (delete-lvar-use node))
+        (let ((succ (first (block-succ block))))
+          (unlink-blocks block succ)
+          (setf (component-reanalyze (block-component block)) t)
+          (aver (not (block-succ block)))
+          (link-blocks block tail)
+          (cond (ir1-converting-not-optimizing-p
+                 (%delete-lvar-use node))
+                (t (delete-lvar-use node)
+                   (when (null (block-pred succ))
+                     (mark-for-deletion succ)))))
 	t))))
 
 ;;; This is called both by IR1 conversion and IR1 optimization when
@@ -777,7 +799,11 @@
 		      (defined-fun-inlinep leaf)
 		      :no-chance)))
     (cond
-     ((eq inlinep :notinline) (values nil nil))
+     ((eq inlinep :notinline)
+      (let ((info (info :function :info (leaf-source-name leaf))))
+	(when info
+	  (setf (basic-combination-fun-info call) info))
+	(values nil nil)))
      ((not (and (global-var-p leaf)
 		(eq (global-var-kind leaf) :global-function)))
       (values leaf nil))
@@ -795,10 +821,11 @@
 	     ;; called semi-inlining? A more descriptive name would
 	     ;; be nice. -- WHN 2002-01-07
 	     (frob ()
-	       (let ((res (ir1-convert-lambda-for-defun
-			   (defined-fun-inline-expansion leaf)
-			   leaf t
-			   #'ir1-convert-inline-lambda)))
+	       (let ((res (let ((*allow-instrumenting* t))
+                            (ir1-convert-lambda-for-defun
+                             (defined-fun-inline-expansion leaf)
+                             leaf t
+                             #'ir1-convert-inline-lambda))))
 		 (setf (defined-fun-functional leaf) res)
 		 (change-ref-leaf ref res))))
 	(if ir1-converting-not-optimizing-p
@@ -812,7 +839,10 @@
      (t
       (let ((info (info :function :info (leaf-source-name leaf))))
 	(if info
-	    (values leaf (setf (basic-combination-kind call) info))
+	    (values leaf
+		    (progn
+		      (setf (basic-combination-kind call) :known)
+		      (setf (basic-combination-fun-info call) info)))
 	    (values leaf nil)))))))
 
 ;;; Check whether CALL satisfies TYPE. If so, apply the type to the
@@ -831,7 +861,7 @@
 	 (recognize-known-call call ir1-converting-not-optimizing-p))
 	((valid-fun-use call type
 			:argument-test #'always-subtypep
-			:result-test #'always-subtypep
+			:result-test nil
 			;; KLUDGE: Common Lisp is such a dynamic
 			;; language that all we can do here in
 			;; general is issue a STYLE-WARNING. It
@@ -883,7 +913,9 @@
 		 (lvar-uses (basic-combination-fun call))
 		 call))
 	       ((not leaf))
-	       ((and (leaf-has-source-name-p leaf)
+	       ((and (global-var-p leaf)
+                     (eq (global-var-kind leaf) :global-function)
+                     (leaf-has-source-name-p leaf)
                      (or (info :function :source-transform (leaf-source-name leaf))
                          (and info
                               (ir1-attributep (fun-info-attributes info)
@@ -949,7 +981,7 @@
 	       (:aborted
 		(setf (combination-kind node) :error)
 		(when args
-		  (apply #'compiler-warn args))
+		  (apply #'warn args))
 		(remhash node table)
 		nil)
 	       (:failure
@@ -1033,7 +1065,7 @@
  	      (setf (node-reoptimize node) t)
  	      (let ((block (node-block node)))
  		(setf (block-reoptimize block) t)
- 		(setf (component-reoptimize (block-component block)) t)))))))
+ 		(reoptimize-component (block-component block) :maybe)))))))
     reoptimize))
 
 ;;; Take the lambda-expression RES, IR1 convert it in the proper
@@ -1056,10 +1088,9 @@
                                 (block-next (node-block call)))
       (let ((new-fun (ir1-convert-inline-lambda
 		      res
-		      :debug-name (debug-namify "LAMBDA-inlined ~A"
-						(as-debug-name
-						 source-name
-						 "<unknown function>"))))
+		      :debug-name (debug-namify "LAMBDA-inlined "
+						source-name
+						"<unknown function>")))
 	    (ref (lvar-use (combination-fun call))))
 	(change-ref-leaf ref new-fun)
 	(setf (combination-kind call) :full)
@@ -1170,7 +1201,8 @@
              (() (null (rest sets)) :exit-if-null)
              (set-use (principal-lvar-use (set-value set)))
              (() (and (combination-p set-use)
-                      (fun-info-p (combination-kind set-use))
+		      (eq (combination-kind set-use) :known)
+                      (fun-info-p (combination-fun-info set-use))
                       (not (node-to-be-deleted-p set-use))
                       (eq (combination-fun-source-name set-use) '+))
                :exit-if-null)
@@ -1282,8 +1314,10 @@
              (dest (lvar-dest lvar)))
     (when (and
            ;; Think about (LET ((A ...)) (IF ... A ...)): two
-           ;; LVAR-USEs should not be met on one path.
+           ;; LVAR-USEs should not be met on one path. Another problem
+           ;; is with dynamic-extent.
            (eq (lvar-uses lvar) ref)
+           (not (block-delete-p (node-block ref)))
            (typecase dest
              ;; we should not change lifetime of unknown values lvars
              (cast
@@ -1306,9 +1340,24 @@
               t))
            (eq (node-home-lambda ref)
                (lambda-home (lambda-var-home var))))
+      (let ((ref-type (single-value-type (node-derived-type ref))))
+        (cond ((csubtypep (single-value-type (lvar-type arg)) ref-type)
+               (substitute-lvar-uses lvar arg
+                                     ;; Really it is (EQ (LVAR-USES LVAR) REF):
+                                     t)
+               (delete-lvar-use ref))
+              (t
+               (let* ((value (make-lvar))
+                      (cast (insert-cast-before ref value ref-type
+                                                ;; KLUDGE: it should be (TYPE-CHECK 0)
+                                                *policy*)))
+                 (setf (cast-type-to-check cast) *wild-type*)
+                 (substitute-lvar-uses value arg
+                                     ;; FIXME
+                                     t)
+                 (%delete-lvar-use ref)
+                 (add-lvar-use cast lvar)))))
       (setf (node-derived-type ref) *wild-type*)
-      (substitute-lvar-uses lvar arg)
-      (delete-lvar-use ref)
       (change-ref-leaf ref (find-constant nil))
       (delete-ref ref)
       (unlink-node ref)
@@ -1554,14 +1603,14 @@
 	  (when (and min (< total-nvals min))
 	    (compiler-warn
 	     "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
-	     at least ~R."
+              at least ~R."
 	     total-nvals min)
 	    (setf (basic-combination-kind node) :error)
 	    (return-from ir1-optimize-mv-call))
 	  (when (and max (> total-nvals max))
 	    (compiler-warn
 	     "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
-	     at most ~R."
+              at most ~R."
 	     total-nvals max)
 	    (setf (basic-combination-kind node) :error)
 	    (return-from ir1-optimize-mv-call)))
@@ -1723,7 +1772,9 @@
                   (unless next-block
                     (when ctran (ensure-block-start ctran))
                     (setq next-block (first (block-succ (node-block cast))))
-                    (ensure-block-start (node-prev cast)))
+                    (ensure-block-start (node-prev cast))
+                    (reoptimize-lvar lvar)
+                    (setf (lvar-%derived-type value) nil))
                   (%delete-lvar-use use)
                   (add-lvar-use use lvar)
                   (unlink-blocks (node-block use) (node-block cast))
@@ -1744,7 +1795,9 @@
           ;; FIXME: Do it in one step.
           (filter-lvar
            value
-           `(multiple-value-call #'list 'dummy))
+           (if (cast-single-value-p cast)
+               `(list 'dummy)
+               `(multiple-value-call #'list 'dummy)))
           (filter-lvar
            (cast-value cast)
            ;; FIXME: Derived type.