1.0.24.48: Do explicit sign-extension of small signed alien return values

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

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 28a74da..78513e6 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -58,9 +58,8 @@
   (event make-value-cell-event node)
   (let ((leaf (tn-leaf res)))
     (vop make-value-cell node block value
-         (and leaf (leaf-dynamic-extent leaf)
-              ;; FIXME: See bug 419
-              (policy node (> stack-allocate-value-cells 1)))
+         ;; FIXME: See bug 419
+         (and leaf (eq :truly (leaf-dynamic-extent leaf)))
          res)))
 \f
 ;;;; leaf reference
@@ -572,16 +571,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))
-  (aver (= (template-info-arg-count template) (+ (length info-args) 2)))
   (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
-                          (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
-           (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)))))))
 
@@ -649,7 +660,7 @@
     (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))
@@ -681,7 +692,7 @@
     (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
@@ -1430,17 +1441,24 @@
              (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)))
+                          (declare (optimize (speed 2) (debug 0)
+                                             (insert-debug-catch 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)