From 46f4a60387df5259b0e355169dccd97f541a8c31 Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Fri, 17 May 2013 17:21:55 -0400
Subject: [PATCH] Insert typechecks before RAW-INSTANCE-INIT in structure
 constructors

 * Usually, FTYPE declarations ensure that happens, but multiple
   inlining of the same structure constructor cause strangeness.

 * Fixed lp#1177703, reported by Jan Moringen.
---
 NEWS                                 |    2 ++
 src/compiler/generic/vm-ir2tran.lisp |   47 ++++++++++++++++++++++------------
 tests/compiler.impure.lisp           |   12 +++++++++
 3 files changed, 44 insertions(+), 17 deletions(-)

diff --git a/NEWS b/NEWS
index 0cb943e..0c1eb2d 100644
--- a/NEWS
+++ b/NEWS
@@ -41,6 +41,8 @@ changes relative to sbcl-1.1.7:
     failure. (lp#943953)
   * bug fix: Known bad local calls do not cause strange failures when
     emitting or dumping code. (lp#504121)
+  * bug fix: Multiply-inlined structure constructor don't cause IR2-time
+    codegen errors: type checks are inserted as necessary. (lp#1177703)
   * optimization: faster ISQRT on fixnums and small bignums
   * optimization: faster and smaller INTEGER-LENGTH on fixnums on x86-64.
   * optimization: On x86-64, the number of multi-byte NOP instructions used
diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp
index dd820f6..fda40cd 100644
--- a/src/compiler/generic/vm-ir2tran.lisp
+++ b/src/compiler/generic/vm-ir2tran.lisp
@@ -31,7 +31,7 @@
 (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
   (let* ((lvar (node-lvar node))
          (locs (lvar-result-tns lvar
-                                        (list *backend-t-primitive-type*)))
+                                (list *backend-t-primitive-type*)))
          (res (first locs)))
     (vop slot node block (lvar-tn node block object)
          name offset lowtag res)
@@ -75,22 +75,35 @@
             (slot (cdr init)))
         (case kind
           (:slot
-           (let ((raw-type (pop slot))
-                 (arg-tn (lvar-tn node block (pop args))))
-             (macrolet ((make-case ()
-                          `(ecase raw-type
-                             ((t)
-                              (vop init-slot node block object arg-tn
-                                   name (+ sb!vm:instance-slots-offset slot) lowtag))
-                             ,@(mapcar (lambda (rsd)
-                                         `(,(sb!kernel::raw-slot-data-raw-type rsd)
-                                            (vop ,(sb!kernel::raw-slot-data-init-vop rsd)
-                                                 node block
-                                                 object arg-tn instance-length slot)))
-                                       #!+raw-instance-init-vops
-                                       sb!kernel::*raw-slot-data-list*
-                                       #!-raw-instance-init-vops
-                                       nil))))
+           (let* ((raw-type (pop slot))
+                  (arg (pop args))
+                  (arg-tn (lvar-tn node block arg)))
+             (macrolet
+                 ((make-case ()
+                    `(ecase raw-type
+                       ((t)
+                        (vop init-slot node block object arg-tn
+                             name (+ sb!vm:instance-slots-offset slot) lowtag))
+                       ,@(mapcar
+                          (lambda (rsd)
+                            (let ((specifier (sb!kernel::raw-slot-data-raw-type
+                                              rsd)))
+                              `(,specifier
+                                (let ((type (specifier-type ',specifier))
+                                      (arg-tn arg-tn))
+                                  (unless (csubtypep (lvar-type arg) type)
+                                    (let ((tmp (make-normal-tn
+                                                (primitive-type type))))
+                                      (emit-type-check node block arg-tn
+                                                       tmp type)
+                                      (setf arg-tn tmp)))
+                                  (vop ,(sb!kernel::raw-slot-data-init-vop rsd)
+                                       node block
+                                       object arg-tn instance-length slot)))))
+                          #!+raw-instance-init-vops
+                          sb!kernel::*raw-slot-data-list*
+                          #!-raw-instance-init-vops
+                          nil))))
                (make-case))))
           (:dd
            (vop init-slot node block object
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index b434089..080d5c8 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -2391,4 +2391,16 @@
     (unwind-protect (compile-file src)
       (ignore-errors (delete-file obj)))))
 
+(declaim (inline vec-1177703))
+(defstruct (vec-1177703 (:constructor vec-1177703 (&optional x)))
+  (x 0.0d0 :type double-float))
+
+(declaim (inline norm-1177703))
+(defun norm-1177703 (v)
+  (vec-1177703 (sqrt (vec-1177703-x v))))
+
+(test-util:with-test (:name :bug-1177703)
+  (compile nil `(lambda (x)
+                  (norm-1177703 (vec-1177703 x)))))
+
 ;;; success
-- 
1.7.10.4