cleanup: gencgc copy_unboxed_object and shared gc_general_copy_object

[sbcl.git] / src / compiler / ir2tran.lisp

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index ebec113..4386573 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -91,29 +91,41 @@
 
 ;;; If LEAF already has a constant TN, return that, otherwise make a
 ;;; TN for it.
-(defun constant-tn (leaf)
+(defun constant-tn (leaf boxedp)
   (declare (type constant leaf))
-  (or (leaf-info leaf)
-      (setf (leaf-info leaf)
-            (make-constant-tn leaf))))
+  ;; When convenient we can have both a boxed and unboxed TN for
+  ;; constant.
+  (if boxedp
+      (or (constant-boxed-tn leaf)
+          (setf (constant-boxed-tn leaf) (make-constant-tn leaf t)))
+      (or (leaf-info leaf)
+          (setf (leaf-info leaf) (make-constant-tn leaf nil)))))
 
 ;;; Return a TN that represents the value of LEAF, or NIL if LEAF
 ;;; isn't directly represented by a TN. ENV is the environment that
 ;;; the reference is done in.
-(defun leaf-tn (leaf env)
+(defun leaf-tn (leaf env boxedp)
   (declare (type leaf leaf) (type physenv env))
   (typecase leaf
     (lambda-var
      (unless (lambda-var-indirect leaf)
        (find-in-physenv leaf env)))
-    (constant (constant-tn leaf))
+    (constant (constant-tn leaf boxedp))
     (t nil)))
 
 ;;; This is used to conveniently get a handle on a constant TN during
 ;;; IR2 conversion. It returns a constant TN representing the Lisp
 ;;; object VALUE.
 (defun emit-constant (value)
-  (constant-tn (find-constant value)))
+  (constant-tn (find-constant value) t))
+
+(defun boxed-ref-p (ref)
+  (let ((dest (lvar-dest (ref-lvar ref))))
+    (cond ((and (basic-combination-p dest) (eq :full (basic-combination-kind dest)))
+           t)
+          ;; Other cases?
+          (t
+           nil))))
 
 ;;; Convert a REF node. The reference must not be delayed.
 (defun ir2-convert-ref (node block)
@@ -134,10 +146,14 @@
           ((and indirect
                 (not (eq (node-physenv node)
                          (lambda-physenv (lambda-var-home leaf)))))
-           (vop ancestor-frame-ref node block tn (leaf-info leaf) res))
+           (let ((reffer (third (primitive-type-indirect-cell-type
+                                 (primitive-type (leaf-type leaf))))))
+             (if reffer
+                 (funcall reffer node block tn (leaf-info leaf) res)
+                 (vop ancestor-frame-ref node block tn (leaf-info leaf) res))))
           (t (emit-move node block tn res)))))
       (constant
-       (emit-move node block (constant-tn leaf) res))
+       (emit-move node block (constant-tn leaf (boxed-ref-p node)) res))
       (functional
        (ir2-convert-closure node block leaf res))
       (global-var
@@ -335,7 +351,11 @@
             ((and indirect
                   (not (eq (node-physenv node)
                            (lambda-physenv (lambda-var-home leaf)))))
-             (vop ancestor-frame-set node block tn val (leaf-info leaf)))
+             (let ((setter (fourth (primitive-type-indirect-cell-type
+                                    (primitive-type (leaf-type leaf))))))
+             (if setter
+                 (funcall setter node block tn val (leaf-info leaf))
+                 (vop ancestor-frame-set node block tn val (leaf-info leaf)))))
             (t (emit-move node block val tn))))))
       (global-var
        (aver (symbolp (leaf-source-name leaf)))
@@ -370,7 +390,7 @@
           (ecase (ir2-lvar-kind 2lvar)
             (:delayed
              (let ((ref (lvar-uses lvar)))
-               (leaf-tn (ref-leaf ref) (node-physenv ref))))
+               (leaf-tn (ref-leaf ref) (node-physenv ref) (boxed-ref-p ref))))
             (:fixed
              (aver (= (length (ir2-lvar-locs 2lvar)) 1))
              (first (ir2-lvar-locs 2lvar)))))
@@ -631,13 +651,15 @@
            (emit-template node block template args nil
                           (list* (block-label consequent) not-p
                                  info-args))
-           (unless (drop-thru-p if alternative)
-             (vop branch node block (block-label alternative))))
+           (if (drop-thru-p if alternative)
+               (register-drop-thru alternative)
+               (vop branch node block (block-label alternative))))
           (t
            (emit-template node block template args nil info-args)
            (vop branch-if node block (block-label consequent) flags not-p)
-           (unless (drop-thru-p if alternative)
-             (vop branch node block (block-label alternative)))))))
+           (if (drop-thru-p if alternative)
+               (register-drop-thru alternative)
+               (vop branch node block (block-label alternative)))))))
 
 ;;; Convert an IF that isn't the DEST of a conditional template.
 (defun ir2-convert-if (node block)
@@ -657,7 +679,7 @@
   (let* ((type (node-derived-type call))
          (types
           (mapcar #'primitive-type
-                  (if (values-type-p type)
+                  (if (args-type-p type)
                       (append (args-type-required type)
                               (args-type-optional type))
                       (list type))))
@@ -947,7 +969,7 @@
           ((node-tail-p node)
            (ir2-convert-tail-local-call node block fun))
           (t
-           (let ((start (block-label (lambda-block fun)))
+           (let ((start (block-trampoline (lambda-block fun)))
                  (returns (tail-set-info (lambda-tail-set fun)))
                  (lvar (node-lvar node)))
              (ecase (if returns
@@ -1472,7 +1494,17 @@
   (binding* ((lvar (node-lvar node) :exit-if-null)
              (2lvar (lvar-info lvar)))
     (ecase (ir2-lvar-kind 2lvar)
-      (:fixed (ir2-convert-full-call node block))
+      (:fixed
+       ;; KLUDGE: this is very much unsafe, and can leak random stack values.
+       ;; OTOH, I think the :FIXED case can only happen with (safety 0) in the
+       ;; first place.
+       ;;  -PK
+       (loop for loc in (ir2-lvar-locs 2lvar)
+             for idx upfrom 0
+             do (vop sb!vm::more-arg node block
+                     (lvar-tn node block context)
+                     (emit-constant idx)
+                     loc)))
       (:unknown
        (let ((locs (ir2-lvar-locs 2lvar)))
          (vop* %more-arg-values node block
@@ -1809,7 +1841,9 @@
                                 (aver (not named))
                                 tn)))))))
               ((not (eq (ir2-block-next 2block) (block-info target)))
-               (vop branch last 2block (block-label target)))))))
+               (vop branch last 2block (block-label target)))
+              (t
+               (register-drop-thru target))))))
 
   (values))