1.0.32.12: Fix slot-value on specialized parameters in SVUC methods

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

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index ca486d1..4796850 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -56,10 +56,13 @@
 (defevent make-value-cell-event "Allocate heap value cell for lexical var.")
 (defun emit-make-value-cell (node block value res)
   (event make-value-cell-event node)
 (defevent make-value-cell-event "Allocate heap value cell for lexical var.")
 (defun emit-make-value-cell (node block value res)
   (event make-value-cell-event node)

-  (let ((leaf (tn-leaf res)))
+  (let* ((leaf (tn-leaf res))
+         (dx (when leaf (leaf-dynamic-extent leaf))))
+    (when (and dx (neq :truly dx) (leaf-has-source-name-p leaf))
+      (compiler-notify "cannot stack allocate value cell for ~S" (leaf-source-name leaf)))

     (vop make-value-cell node block value
          ;; FIXME: See bug 419
     (vop make-value-cell node block value
          ;; FIXME: See bug 419

-         (and leaf (eq :truly (leaf-dynamic-extent leaf)))
+         (eq :truly dx)

          res)))
 \f
 ;;;; leaf reference
          res)))
 \f
 ;;;; leaf reference

@@ -141,12 +144,18 @@
        (let ((unsafe (policy node (zerop safety)))
              (name (leaf-source-name leaf)))
          (ecase (global-var-kind leaf)
        (let ((unsafe (policy node (zerop safety)))
              (name (leaf-source-name leaf)))
          (ecase (global-var-kind leaf)

-           ((:special :global)
+           ((:special :unknown)

             (aver (symbolp name))
             (let ((name-tn (emit-constant name)))
             (aver (symbolp name))
             (let ((name-tn (emit-constant name)))

-              (if unsafe
+              (if (or unsafe (info :variable :always-bound name))

                   (vop fast-symbol-value node block name-tn res)
                   (vop symbol-value node block name-tn res))))
                   (vop fast-symbol-value node block name-tn res)
                   (vop symbol-value node block name-tn res))))

+           (:global
+            (aver (symbolp name))
+            (let ((name-tn (emit-constant name)))
+              (if (or unsafe (info :variable :always-bound name))
+                  (vop fast-symbol-global-value node block name-tn res)
+                  (vop symbol-global-value node block name-tn res))))

            (:global-function
             (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
               (if unsafe
            (:global-function
             (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
               (if unsafe

@@ -246,7 +255,11 @@
         (vop current-stack-pointer call 2block
              (ir2-lvar-stack-pointer (lvar-info leaves))))
       (dolist (leaf (lvar-value leaves))
         (vop current-stack-pointer call 2block
              (ir2-lvar-stack-pointer (lvar-info leaves))))
       (dolist (leaf (lvar-value leaves))

-        (binding* ((xep (functional-entry-fun leaf) :exit-if-null)
+        (binding* ((xep (awhen (functional-entry-fun leaf)
+                          ;; if the xep's been deleted then we can skip it
+                          (if (eq (functional-kind it) :deleted)
+                              nil it))
+                        :exit-if-null)

                    (nil (aver (xep-p xep)))
                    (entry-info (lambda-info xep) :exit-if-null)
                    (tn (entry-info-closure-tn entry-info) :exit-if-null)
                    (nil (aver (xep-p xep)))
                    (entry-info (lambda-info xep) :exit-if-null)
                    (tn (entry-info-closure-tn entry-info) :exit-if-null)

@@ -298,10 +311,13 @@
                (vop value-cell-set node block tn val)
                (emit-move node block val tn)))))
       (global-var
                (vop value-cell-set node block tn val)
                (emit-move node block val tn)))))
       (global-var

+       (aver (symbolp (leaf-source-name leaf)))

        (ecase (global-var-kind leaf)
          ((:special)
        (ecase (global-var-kind leaf)
          ((:special)

-          (aver (symbolp (leaf-source-name leaf)))
-          (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
+          (vop set node block (emit-constant (leaf-source-name leaf)) val))
+         ((:global)
+          (vop %set-symbol-global-value node
+               block (emit-constant (leaf-source-name leaf)) val)))))

     (when locs
       (emit-move node block val (first locs))
       (move-lvar-result node block locs lvar)))
     (when locs
       (emit-move node block val (first locs))
       (move-lvar-result node block locs lvar)))

@@ -571,16 +587,28 @@
   (declare (type node node) (type ir2-block block)
            (type template template) (type (or tn-ref null) args)
            (list info-args) (type cif if) (type boolean not-p))
   (declare (type node node) (type ir2-block block)
            (type template template) (type (or tn-ref null) args)
            (list info-args) (type cif if) (type boolean not-p))

-  (aver (= (template-info-arg-count template) (+ (length info-args) 2)))

   (let ((consequent (if-consequent if))
   (let ((consequent (if-consequent if))

-        (alternative (if-alternative if)))
-    (cond ((drop-thru-p if consequent)
+        (alternative (if-alternative if))
+        (flags       (and (consp (template-result-types template))
+                          (rest (template-result-types template)))))
+    (aver (= (template-info-arg-count template)
+             (+ (length info-args)
+                (if flags 0 2))))
+    (when not-p
+      (rotatef consequent alternative)
+      (setf not-p nil))
+    (when (drop-thru-p if consequent)
+      (rotatef consequent alternative)
+      (setf not-p t))
+    (cond ((not flags)

            (emit-template node block template args nil
            (emit-template node block template args nil

-                          (list* (block-label alternative) (not not-p)
-                                 info-args)))
+                          (list* (block-label consequent) not-p
+                                 info-args))
+           (unless (drop-thru-p if alternative)
+             (vop branch node block (block-label alternative))))

           (t
           (t

-           (emit-template node block template args nil
-                          (list* (block-label consequent) not-p info-args))
+           (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)))))))
 
            (unless (drop-thru-p if alternative)
              (vop branch node block (block-label alternative)))))))
 

@@ -648,7 +676,7 @@
     (multiple-value-bind (args info-args)
         (reference-args call block (combination-args call) template)
       (aver (not (template-more-results-type template)))
     (multiple-value-bind (args info-args)
         (reference-args call block (combination-args call) template)
       (aver (not (template-more-results-type template)))

-      (if (eq rtypes :conditional)
+      (if (template-conditional-p template)

           (ir2-convert-conditional call block template args info-args
                                    (lvar-dest lvar) nil)
           (let* ((results (make-template-result-tns call lvar rtypes))
           (ir2-convert-conditional call block template args info-args
                                    (lvar-dest lvar) nil)
           (let* ((results (make-template-result-tns call lvar rtypes))

@@ -680,7 +708,7 @@
     (multiple-value-bind (args info-args)
         (reference-args call block (cddr (combination-args call)) template)
       (aver (not (template-more-results-type template)))
     (multiple-value-bind (args info-args)
         (reference-args call block (cddr (combination-args call)) template)
       (aver (not (template-more-results-type template)))

-      (aver (not (eq rtypes :conditional)))
+      (aver (not (template-conditional-p template)))

       (aver (null info-args))
 
       (if info
       (aver (null info-args))
 
       (if info

@@ -1241,15 +1269,21 @@
   (values))
 \f
 ;;;; debugger hooks
   (values))
 \f
 ;;;; debugger hooks

+;;;;
+;;;; These are used by the debugger to find the top function on the
+;;;; stack. They return the OLD-FP and RETURN-PC for the current
+;;;; function as multiple values.

 
 

-;;; This is used by the debugger to find the top function on the
-;;; stack. It returns the OLD-FP and RETURN-PC for the current
-;;; function as multiple values.
-(defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block)
+(defoptimizer (%caller-frame ir2-convert) (() node block)

   (let ((ir2-physenv (physenv-info (node-physenv node))))
     (move-lvar-result node block
   (let ((ir2-physenv (physenv-info (node-physenv node))))
     (move-lvar-result node block

-                      (list (ir2-physenv-old-fp ir2-physenv)
-                            (ir2-physenv-return-pc ir2-physenv))
+                      (list (ir2-physenv-old-fp ir2-physenv))
+                      (node-lvar node))))
+
+(defoptimizer (%caller-pc ir2-convert) (() node block)
+  (let ((ir2-physenv (physenv-info (node-physenv node))))
+    (move-lvar-result node block
+                      (list (ir2-physenv-return-pc ir2-physenv))

                       (node-lvar node))))
 \f
 ;;;; multiple values
                       (node-lvar node))))
 \f
 ;;;; multiple values

@@ -1434,16 +1468,17 @@
                             (dolist (var vars)
                               ;; CLHS says "bound and then made to have no value" -- user
                               ;; should not be able to tell the difference between that and this.
                             (dolist (var vars)
                               ;; CLHS says "bound and then made to have no value" -- user
                               ;; should not be able to tell the difference between that and this.

-                              (about-to-modify-symbol-value var "bind ~S")
+                              (about-to-modify-symbol-value var 'progv)

                               (%primitive bind unbound-marker var))))
                         (,bind (vars vals)
                               (%primitive bind unbound-marker var))))
                         (,bind (vars vals)

-                          (declare (optimize (speed 2) (debug 0)))
+                          (declare (optimize (speed 2) (debug 0)
+                                             (insert-debug-catch 0)))

                           (cond ((null vars))
                                 ((null vals) (,unbind vars))
                                 (t
                                  (let ((val (car vals))
                                        (var (car vars)))
                           (cond ((null vars))
                                 ((null vals) (,unbind vars))
                                 (t
                                  (let ((val (car vals))
                                        (var (car vars)))

-                                   (about-to-modify-symbol-value var "bind ~S" val)
+                                   (about-to-modify-symbol-value var 'progv val t)

                                    (%primitive bind val var))
                                  (,bind (cdr vars) (cdr vals))))))
                  (,bind ,vars ,vals))
                                    (%primitive bind val var))
                                  (,bind (cdr vars) (cdr vals))))))
                  (,bind ,vars ,vals))