X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-ir2tran.lisp;h=fda40cdd6f6553ed2261a01558d4723f8fa86184;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=7a0a1ee3369c02c9518ec3aa0ebdbd11249388a6;hpb=f7faed97898dd0e94a18b0d1fca03aaa0fe24ab0;p=sbcl.git

diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp
index 7a0a1ee..fda40cd 100644
--- a/src/compiler/generic/vm-ir2tran.lisp
+++ b/src/compiler/generic/vm-ir2tran.lisp
@@ -14,13 +14,24 @@
            nil)
 
 #!+stack-allocatable-fixed-objects
-(defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args) node dx)
+(defoptimizer (%make-structure-instance stack-allocate-result) ((defstruct-description &rest args) node dx)
+  (aver (constant-lvar-p defstruct-description))
+  ;; A structure instance can be stack-allocated if it has no raw
+  ;; slots, or if we're on a target with a conservatively-scavenged
+  ;; stack.  We have no reader conditional for stack conservation, but
+  ;; it turns out that the only time stack conservation is in play is
+  ;; when we're on GENCGC (since CHENEYGC doesn't have conservation)
+  ;; and C-STACK-IS-CONTROL-STACK (otherwise, the C stack is the
+  ;; number stack, and we precisely-scavenge the control stack).
+  #!-(and :gencgc :c-stack-is-control-stack)
+  (zerop (sb!kernel::dd-raw-length (lvar-value defstruct-description)))
+  #!+(and :gencgc :c-stack-is-control-stack)
   t)
 
 (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)
@@ -64,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
@@ -264,13 +288,10 @@
 #!+stack-allocatable-lists
 (progn
   (defoptimizer (list stack-allocate-result) ((&rest args) node dx)
-    (declare (ignore node dx))
     (not (null args)))
   (defoptimizer (list* stack-allocate-result) ((&rest args) node dx)
-    (declare (ignore node dx))
     (not (null (rest args))))
   (defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args) node dx)
-    (declare (ignore node dx))
     t))
 
 ;;; ...conses