0.7.11.10:

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

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 01e908b..3d848ac 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -266,7 +266,7 @@
 ;;;; utilities for receiving fixed values
 
 ;;; Return a TN that can be referenced to get the value of CONT. CONT
-;;; must be LTN-Annotated either as a delayed leaf ref or as a fixed,
+;;; must be LTN-ANNOTATED either as a delayed leaf ref or as a fixed,
 ;;; single-value continuation. If a type check is called for, do it.
 ;;;
 ;;; The primitive-type of the result will always be the same as the
@@ -291,7 +291,7 @@
 
     (cond ((and (eq (continuation-type-check cont) t)
                (multiple-value-bind (check types)
-                   (continuation-check-types cont)
+                   (continuation-check-types cont nil)
                  (aver (eq check :simple))
                  ;; If the proven type is a subtype of the possibly
                  ;; weakened type check then it's always true and is
@@ -323,7 +323,7 @@
         (nlocs (length locs)))
     (aver (= nlocs (length ptypes)))
     (if (eq (continuation-type-check cont) t)
-       (multiple-value-bind (check types) (continuation-check-types cont)
+       (multiple-value-bind (check types) (continuation-check-types cont nil)
          (aver (eq check :simple))
          (let ((ntypes (length types)))
            (mapcar (lambda (from to-type assertion)
@@ -470,7 +470,7 @@
 \f
 ;;;; template conversion
 
-;;; Build a TN-Refs list that represents access to the values of the
+;;; Build a TN-REFS list that represents access to the values of the
 ;;; specified list of continuations ARGS for TEMPLATE. Any :CONSTANT
 ;;; arguments are returned in the second value as a list rather than
 ;;; being accessed as a normal argument. NODE and BLOCK provide the
@@ -588,7 +588,7 @@
         cont
         (find-template-result-types call cont template rtypes)))))
 
-;;; Get the operands into TNs, make TN-Refs for them, and then call
+;;; Get the operands into TNs, make TN-REFs for them, and then call
 ;;; the template emit function.
 (defun ir2-convert-template (call block)
   (declare (type combination call) (type ir2-block block))
@@ -979,7 +979,7 @@
 ;;; list.
 (defvar *always-optimized-away*
   '(;; This should always be DEFTRANSFORMed away, but wasn't in a bug
-    ;; reported to cmucl-imp@cons.org 2000-06-20.
+    ;; reported to cmucl-imp 2000-06-20.
     %instance-ref
     ;; These should always turn into VOPs, but wasn't in a bug which
     ;; appeared when LTN-POLICY stuff was being tweaked in
@@ -1290,14 +1290,15 @@
 (defoptimizer (values-list ir2-convert) ((list) node block)
   (let* ((cont (node-cont node))
         (2cont (continuation-info cont)))
-    (when 2cont
-      (ecase (ir2-continuation-kind 2cont)
-       (:fixed (ir2-convert-full-call node block))
-       (:unknown
-        (let ((locs (ir2-continuation-locs 2cont)))
-          (vop* values-list node block
-                ((continuation-tn node block list) nil)
-                ((reference-tn-list locs t)))))))))
+    (cond ((and 2cont
+                (eq (ir2-continuation-kind 2cont) :unknown))
+           (let ((locs (ir2-continuation-locs 2cont)))
+             (vop* values-list node block
+                   ((continuation-tn node block list) nil)
+                   ((reference-tn-list locs t)))))
+          (t (aver (or (not 2cont) ; i.e. we want to check the argument
+                       (eq (ir2-continuation-kind 2cont) :fixed)))
+             (ir2-convert-full-call node block)))))
 
 (defoptimizer (%more-arg-values ir2-convert) ((context start count) node block)
   (let* ((cont (node-cont node))
@@ -1332,15 +1333,26 @@
 (def-ir1-translator progv ((vars vals &body body) start cont)
   (ir1-convert
    start cont
-   (once-only ((n-save-bs '(%primitive current-binding-pointer)))
-     `(unwind-protect
-         (progn
-           (mapc (lambda (var val)
-                   (%primitive bind val var))
-                 ,vars
-                 ,vals)
-           ,@body)
-       (%primitive unbind-to-here ,n-save-bs)))))
+   (let ((bind (gensym "BIND"))
+         (unbind (gensym "UNBIND")))
+     (once-only ((n-save-bs '(%primitive current-binding-pointer)))
+                `(unwind-protect
+                      (progn
+                        (labels ((,unbind (vars)
+                                   (declare (optimize (speed 2) (debug 0)))
+                                   (dolist (var vars)
+                                     (%primitive bind nil var)
+                                     (makunbound var)))
+                                 (,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))))))
+                          (,bind ,vars ,vals))
+                        nil
+                        ,@body)
+                   (%primitive unbind-to-here ,n-save-bs))))))
 \f
 ;;;; non-local exit