1.0.19.3: more careful PROGV and SET

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

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 3e1385d..947389f 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -57,7 +57,10 @@
 (defun emit-make-value-cell (node block value res)
   (event make-value-cell-event node)
   (let ((leaf (tn-leaf res)))
 (defun emit-make-value-cell (node block value res)
   (event make-value-cell-event node)
   (let ((leaf (tn-leaf res)))

-    (vop make-value-cell node block value (and leaf (leaf-dynamic-extent leaf))
+    (vop make-value-cell node block value
+         (and leaf (leaf-dynamic-extent leaf)
+              ;; FIXME: See bug 419
+              (policy node (> stack-allocate-value-cells 1)))

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

@@ -132,13 +135,7 @@
              (vop value-cell-ref node block tn res)
              (emit-move node block tn res))))
       (constant
              (vop value-cell-ref node block tn res)
              (emit-move node block tn res))))
       (constant

-       (if (legal-immediate-constant-p leaf)
-           (emit-move node block (constant-tn leaf) res)
-           (let* ((name (leaf-source-name leaf))
-                  (name-tn (emit-constant name)))
-             (if (policy node (zerop safety))
-                 (vop fast-symbol-value node block name-tn res)
-                 (vop symbol-value node block name-tn res)))))
+       (emit-move node block (constant-tn leaf) res))

       (functional
        (ir2-convert-closure node block leaf res))
       (global-var
       (functional
        (ir2-convert-closure node block leaf res))
       (global-var

@@ -303,7 +300,7 @@
                (emit-move node block val tn)))))
       (global-var
        (ecase (global-var-kind leaf)
                (emit-move node block val tn)))))
       (global-var
        (ecase (global-var-kind leaf)

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

           (aver (symbolp (leaf-source-name leaf)))
           (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
     (when locs
           (aver (symbolp (leaf-source-name leaf)))
           (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
     (when locs

@@ -598,61 +595,49 @@
     (ir2-convert-conditional node block (template-or-lose 'if-eq)
                              test-ref () node t)))
 
     (ir2-convert-conditional node block (template-or-lose 'if-eq)
                              test-ref () node t)))
 

-;;; Return a list of primitive-types that we can pass to
-;;; LVAR-RESULT-TNS describing the result types we want for a
-;;; template call. We duplicate here the determination of output type
-;;; that was done in initially selecting the template, so we know that
-;;; the types we find are allowed by the template output type
-;;; restrictions.
-(defun find-template-result-types (call template rtypes)
-  (declare (type combination call)
-           (type template template) (list rtypes))
-  (declare (ignore template))
-  (let* ((dtype (node-derived-type call))
-         (type dtype)
-         (types (mapcar #'primitive-type
-                        (if (values-type-p type)
-                            (append (values-type-required type)
-                                    (values-type-optional type))
-                            (list type)))))
-    (let ((nvals (length rtypes))
-          (ntypes (length types)))
-      (cond ((< ntypes nvals)
-             (append types
-                     (make-list (- nvals ntypes)
-                                :initial-element *backend-t-primitive-type*)))
-            ((> ntypes nvals)
-             (subseq types 0 nvals))
-            (t
-             types)))))
-
-;;; Return a list of TNs usable in a CALL to TEMPLATE delivering
-;;; values to LVAR. As an efficiency hack, we pick off the common case
-;;; where the LVAR is fixed values and has locations that satisfy the
-;;; result restrictions. This can fail when there is a type check or a
-;;; values count mismatch.
-(defun make-template-result-tns (call lvar template rtypes)
+;;; Return a list of primitive-types that we can pass to LVAR-RESULT-TNS
+;;; describing the result types we want for a template call. We are really
+;;; only interested in the number of results required: in normal case
+;;; TEMPLATE-RESULTS-OK has already checked them.
+(defun find-template-result-types (call rtypes)
+  (let* ((type (node-derived-type call))
+         (types
+          (mapcar #'primitive-type
+                  (if (values-type-p type)
+                      (append (args-type-required type)
+                              (args-type-optional type))
+                      (list type))))
+         (primitive-t *backend-t-primitive-type*))
+    (loop for rtype in rtypes
+          for type = (or (pop types) primitive-t)
+          collect type)))
+
+;;; Return a list of TNs usable in a CALL to TEMPLATE delivering values to
+;;; LVAR. As an efficiency hack, we pick off the common case where the LVAR is
+;;; fixed values and has locations that satisfy the result restrictions. This
+;;; can fail when there is a type check or a values count mismatch.
+(defun make-template-result-tns (call lvar rtypes)

   (declare (type combination call) (type (or lvar null) lvar)
   (declare (type combination call) (type (or lvar null) lvar)

-           (type template template) (list rtypes))
+           (list rtypes))

   (let ((2lvar (when lvar (lvar-info lvar))))
     (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed))
         (let ((locs (ir2-lvar-locs 2lvar)))
           (if (and (= (length rtypes) (length locs))
                    (do ((loc locs (cdr loc))
   (let ((2lvar (when lvar (lvar-info lvar))))
     (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed))
         (let ((locs (ir2-lvar-locs 2lvar)))
           (if (and (= (length rtypes) (length locs))
                    (do ((loc locs (cdr loc))

-                        (rtype rtypes (cdr rtype)))
+                        (rtypes rtypes (cdr rtypes)))

                        ((null loc) t)
                      (unless (operand-restriction-ok
                        ((null loc) t)
                      (unless (operand-restriction-ok

-                              (car rtype)
+                              (car rtypes)

                               (tn-primitive-type (car loc))
                               :t-ok nil)
                        (return nil))))
               locs
               (lvar-result-tns
                lvar
                               (tn-primitive-type (car loc))
                               :t-ok nil)
                        (return nil))))
               locs
               (lvar-result-tns
                lvar

-               (find-template-result-types call template rtypes))))
+               (find-template-result-types call rtypes))))

         (lvar-result-tns
          lvar
         (lvar-result-tns
          lvar

-         (find-template-result-types call template rtypes)))))
+         (find-template-result-types call rtypes)))))

 
 ;;; Get the operands into TNs, make TN-REFs for them, and then call
 ;;; the template emit function.
 
 ;;; Get the operands into TNs, make TN-REFs for them, and then call
 ;;; the template emit function.

@@ -667,7 +652,7 @@
       (if (eq rtypes :conditional)
           (ir2-convert-conditional call block template args info-args
                                    (lvar-dest lvar) nil)
       (if (eq rtypes :conditional)
           (ir2-convert-conditional call block template args info-args
                                    (lvar-dest lvar) nil)

-          (let* ((results (make-template-result-tns call lvar template rtypes))
+          (let* ((results (make-template-result-tns call lvar rtypes))

                  (r-refs (reference-tn-list results t)))
             (aver (= (length info-args)
                      (template-info-arg-count template)))
                  (r-refs (reference-tn-list results t)))
             (aver (= (length info-args)
                      (template-info-arg-count template)))

@@ -691,7 +676,7 @@
          (info (lvar-value info))
          (lvar (node-lvar call))
          (rtypes (template-result-types template))
          (info (lvar-value info))
          (lvar (node-lvar call))
          (rtypes (template-result-types template))

-         (results (make-template-result-tns call lvar template rtypes))
+         (results (make-template-result-tns call lvar rtypes))

          (r-refs (reference-tn-list results t)))
     (multiple-value-bind (args info-args)
         (reference-args call block (cddr (combination-args call)) template)
          (r-refs (reference-tn-list results t)))
     (multiple-value-bind (args info-args)
         (reference-args call block (cddr (combination-args call)) template)

@@ -705,6 +690,12 @@
 
       (move-lvar-result call block results lvar)))
   (values))
 
       (move-lvar-result call block results lvar)))
   (values))

+
+(defoptimizer (%%primitive derive-type) ((template info &rest args))
+  (let ((type (template-type (lvar-value template))))
+    (if (fun-type-p type)
+        (fun-type-returns type)
+        *wild-type*)))

 \f
 ;;;; local call
 
 \f
 ;;;; local call
 

@@ -1439,17 +1430,23 @@
              (progn
                (labels ((,unbind (vars)
                           (declare (optimize (speed 2) (debug 0)))
              (progn
                (labels ((,unbind (vars)
                           (declare (optimize (speed 2) (debug 0)))

-                          (dolist (var vars)
-                            (%primitive bind nil var)
-                            (makunbound var)))
+                          (let ((unbound-marker (%primitive make-other-immediate-type
+                                                            0 sb!vm:unbound-marker-widetag)))
+                            (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")
+                              (%primitive bind unbound-marker var))))

                         (,bind (vars vals)
                           (declare (optimize (speed 2) (debug 0)))
                           (cond ((null vars))
                                 ((null vals) (,unbind vars))
                         (,bind (vars vals)
                           (declare (optimize (speed 2) (debug 0)))
                           (cond ((null vars))
                                 ((null vals) (,unbind vars))

-                                (t (%primitive bind
-                                               (car vals)
-                                               (car vars))
-                                   (,bind (cdr vars) (cdr vals))))))
+                                (t
+                                 (let ((val (car vals))
+                                       (var (car vars)))
+                                   (about-to-modify-symbol-value var "bind ~S" val)
+                                   (%primitive bind val var))
+                                 (,bind (cdr vars) (cdr vals))))))

                  (,bind ,vars ,vals))
                nil
                ,@body)
                  (,bind ,vars ,vals))
                nil
                ,@body)