sb-bsd-sockets: foreign memory leak in GET-PROTOCOL-BY-NAME

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

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index d764e82..1674834 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -134,7 +134,11 @@
           ((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))
@@ -335,7 +339,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)))
@@ -1474,7 +1482,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)
+                     (make-constant-tn (find-constant idx))
+                     loc)))
       (:unknown
        (let ((locs (ir2-lvar-locs 2lvar)))
          (vop* %more-arg-values node block