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

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 73a3247..3d06bd0 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -195,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
@@ -1352,11 +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
-                            ;; Really it is (EQ (LVAR-USES LVAR) REF):
-                            t)
-      (delete-lvar-use ref)
       (change-ref-leaf ref (find-constant nil))
       (delete-ref ref)
       (unlink-node ref)