[armedbear-cvs] r13129 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Thu Jan  6 12:26:32 2011
New Revision: 13129

Log:
Remove UNSAFE-P from SINGLE-VALUED-P (pass2).

Note: The use of UNSAFE-P was misguided. TAGBODY returns NIL, not
any of the values in the body. UNSAFE-P was used to determine (non-local)
returns. BLOCKs do not only return the value of the last form, but can
also return any of the values from the VALUES-FORM in RETURN-FROM. Etc, etc.

Modified:
   branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	(original)
+++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Thu Jan  6 12:26:32 2011
@@ -643,8 +643,10 @@
           (t
            (setf (block-non-local-return-p block) t)))
     (when (block-non-local-return-p block)
-      (dformat t "non-local return from block ~S~%" (block-name block))))
-  (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
+      (dformat t "non-local return from block ~S~%" (block-name block)))
+    (let ((value-form (p1 (caddr form))))
+      (push value-form (block-return-value-forms block))
+      (list 'RETURN-FROM name value-form))))
 
 (defun p1-tagbody (form)
   (let* ((block (make-tagbody-node))

Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Thu Jan  6 12:26:32 2011
@@ -579,9 +579,27 @@
 (defknown single-valued-p (t) t)
 (defun single-valued-p (form)
   (cond ((node-p form)
-         (if (tagbody-node-p form)
-             (not (unsafe-p (node-form form)))
-             (single-valued-p (node-form form))))
+         (cond ((tagbody-node-p form)
+                t)
+               ((block-node-p form)
+                (and (single-valued-p (car (last (node-form form))))
+                     ;; return-from value forms
+                     (every #'single-valued-p
+                            (block-return-value-forms form))))
+               ((or (flet-node-p form)
+                    (labels-node-p form)
+                    (let/let*-node-p form)
+                    (m-v-b-node-p form)
+                    (progv-node-p form)
+                    (locally-node-p form)
+                    (synchronized-node-p form))
+                (single-valued-p (car (last (node-form form)))))
+               ((unwind-protect-node-p form)
+                (single-valued-p (second (node-form form))))
+               ((catch-node-p form)
+                nil)
+               (t
+                (assert (not "SINGLE-VALUED-P unhandled NODE-P branch")))))
         ((var-ref-p form)
          t)
         ((atom form)
@@ -590,15 +608,15 @@
          (let ((op (%car form))
                result-type
                compiland)
+           (assert (not (member op '(LET LET* FLET LABELS TAGBODY CATCH
+                                         MULTIPLE-VALUE-BIND
+                                         UNWIND-PROTECT BLOCK PROGV
+                                         LOCALLY))))
            (cond ((eq op 'IF)
                   (and (single-valued-p (third form))
                        (single-valued-p (fourth form))))
                  ((eq op 'PROGN)
                   (single-valued-p (car (last form))))
-                 ((eq op 'BLOCK)
-                  (single-valued-p (car (last form))))
-                 ((memq op '(LET LET*))
-                  (single-valued-p (car (last (cddr form)))))
                  ((memq op '(AND OR))
                   (every #'single-valued-p (cdr form)))
                  ((eq op 'RETURN-FROM)

Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp	Thu Jan  6 12:26:32 2011
@@ -464,7 +464,10 @@
   non-local-return-p
   ;; Contains a variable whose value uniquely identifies the
   ;; lexical scope from this block, to be used by RETURN-FROM
-  id-variable)
+  id-variable
+  ;; A list of all RETURN-FROM value forms associated with this block
+  return-value-forms)
+
 (defknown make-block-node (t) t)
 (defun make-block-node (name)
   (let ((block (%make-block-node name)))