[armedbear-cvs] r11837 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Wed May  6 16:39:51 2009
New Revision: 11837

Log:
Fix ticket #21 finally: JVM stack inconsistency error on
inlining unwind-protect.

The issue in the earlier attempts was that p1 outcomes can only
be compiled once (first try) and that one cannot p1 the same form
twice (one needs to create a copy; second try).

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Wed May  6 16:39:51 2009
@@ -299,8 +299,16 @@
 (defun p1-unwind-protect (form)
   (if (= (length form) 2)
       (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...)
+
+      ;; in order to compile the cleanup forms twice (see
+      ;; p2-unwind-protect-node), we need to p1 them twice; p1 outcomes
+      ;; can be compiled (in the same compiland?) only once.
+      ;;
+      ;; However, p1 transforms the forms being processed, so, we
+      ;; need to copy the forms to create a second copy.
       (let* ((block (make-block-node '(UNWIND-PROTECT)))
              ;; a bit of jumping through hoops...
+             (unwinding-forms (p1-body (copy-tree (cddr form))))
              (unprotected-forms (p1-body (cddr form)))
              ;; ... because only the protected form is
              ;; protected by the UNWIND-PROTECT block
@@ -308,6 +316,7 @@
              (protected-form (p1 (cadr form))))
         (setf (block-form block)
               `(unwind-protect ,protected-form
+                 (progn , at unwinding-forms)
                  , at unprotected-forms))
         block)))
 

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Wed May  6 16:39:51 2009
@@ -7834,18 +7834,29 @@
     (when (= (length form) 2) ; No cleanup form.
       (compile-form (second form) target nil)
       (return-from p2-unwind-protect-node))
+
+    ;; The internal representation of UNWIND-PROTECT
+    ;; as generated by P1-UNWIND-PROTECT differs a bit
+    ;; from what the spec says; ours is:
+    ;; (UNWIND-PROTECT protected-form (progn cleanup-forms) cleanup-forms),
+    ;; because we need to compile the cleanup forms twice and
+    ;; we can compile a p1 outcome only once.
+    ;;
+    ;; We used to use JSR and RET JVM instructions to prevent
+    ;; duplication of output code. However, this led to JVM stack
+    ;; inconsistency errors
+    ;; (see http://trac.common-lisp.net/armedbear/ticket/21)
     (let* ((protected-form (cadr form))
-           (cleanup-forms (cddr form))
+           (unwinding-form (caddr form))
+           (cleanup-forms (cdddr form))
            (*register* *register*)
            (exception-register (allocate-register))
            (result-register (allocate-register))
            (values-register (allocate-register))
-           (return-address-register (allocate-register))
            (BEGIN-PROTECTED-RANGE (gensym))
            (END-PROTECTED-RANGE (gensym))
            (HANDLER (gensym))
-           (EXIT (gensym))
-           (CLEANUP (gensym)))
+           (EXIT (gensym)))
       ;; Make sure there are no leftover multiple return values from previous calls.
       (emit-clear-values)
 
@@ -7857,21 +7868,21 @@
           (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+)
           (astore values-register))
         (label END-PROTECTED-RANGE))
-      (emit 'jsr CLEANUP)
+      (let ((*register* *register*))
+        (compile-form unwinding-form nil nil))
+      (when (single-valued-p protected-form)
+        ;; otherwise, we'll load the values register below
+        (maybe-emit-clear-values unwinding-form))
       (emit 'goto EXIT) ; Jump over handler.
       (label HANDLER) ; Start of exception handler.
       ;; The Throwable object is on the runtime stack. Stack depth is 1.
       (astore exception-register)
-      (emit 'jsr CLEANUP) ; Call cleanup forms.
+      (let ((*register* *register*))
+        (dolist (subform cleanup-forms)
+          (compile-form subform nil nil)))
       (maybe-emit-clear-values cleanup-forms)
       (aload exception-register)
       (emit 'athrow) ; Re-throw exception.
-      (label CLEANUP) ; Cleanup forms.
-      ;; Return address is on stack here.
-      (astore return-address-register)
-      (dolist (subform cleanup-forms)
-        (compile-form subform nil nil))
-      (emit 'ret return-address-register)
       (label EXIT)
       ;; Restore multiple values returned by protected form.
       (unless (single-valued-p protected-form)