Changeset 12170

Timestamp:

10/04/09 12:37:29 (14 years ago)

Author:

ehuelsmann

Message:

Don't throw Go and Return exceptions as means for non-local transfers
of control, if the extent of the defining lexical context has ended.
Throwing the exceptions anyway causes leaking of exceptions and possibly
unwanted thread termination.

Note: This commit breaks MISC.293A, MISC.293B and MISC.293C.

This however is not a problem with this change, but exposes the fact
that our compiler doesn't conform to the JVM specification of
exception handlers: you can't expect the built-up stack to stay in place
when the exception handler is invoked.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• Binding.java (modified) (2 diffs)
• Do.java (modified) (1 diff)
• Environment.java (modified) (3 diffs)
• Lisp.java (modified) (2 diffs)
• Primitives.java (modified) (4 diffs)
• compiler-pass2.lisp (modified) (11 diffs)
• dolist.java (modified) (2 diffs)
• dotimes.java (modified) (2 diffs)

trunk/abcl/src/org/armedbear/lisp/Binding.java

@@ -48 +48 @@
     final LispObject symbol;
 
-    /** Used only for tags. Refers to the environment
-     * relating to the tagbody in which the tag was created.
+    /** Used only for tags and blocks. Refers to the
+     * defining environment.
      *
      */
-    LispObject tagbody = null;
+    Environment env = null;
 
     /** The value bound.
@@ -82 +82 @@
     }
 
-    Binding(LispObject symbol, LispObject tagbody,
+    Binding(LispObject symbol, Environment env,
             LispObject value, Binding next)
     {
         this(symbol, value, next);
-        this.tagbody = tagbody;
+        this.env = env;
     }
 }

trunk/abcl/src/org/armedbear/lisp/Do.java

@@ -199 +199 @@
       {
         thread.lastSpecialBinding = lastSpecialBinding;
+        ext.inactive = true;
       }
   }

trunk/abcl/src/org/armedbear/lisp/Environment.java

@@ -40 +40 @@
   private Binding blocks;
   private Binding tags;
+  public boolean inactive; //default value: false == active
 
   public Environment() {}
@@ -166 +167 @@
   }
 
-  public void addBlock(LispObject tag, LispObject block)
-  {
-    blocks = new Binding(tag, block, blocks);
+  public void addBlock(LispObject symbol, LispObject block)
+  {
+    blocks = new Binding(symbol, this, block, blocks);
   }
 
@@ -183 +184 @@
   }
 
-  public void addTagBinding(LispObject tag, LispObject tagbody, LispObject code)
-  {
-    tags = new Binding(tag, tagbody, code, tags);
+  public Binding getBlockBinding(LispObject block)
+  {
+    Binding binding = blocks;
+    while (binding != null)
+      {
+        if (binding.symbol == block)
+          return binding;
+        binding = binding.next;
+      }
+    return null;
+  }
+
+  public void addTagBinding(LispObject tag, Environment env, LispObject code)
+  {
+    tags = new Binding(tag, env, code, tags);
   }
 

trunk/abcl/src/org/armedbear/lisp/Lisp.java

@@ -645 +645 @@
   }
 
+  /** Throws a Go exception to cause a non-local transfer
+   * of control event, after checking that the extent of
+   * the catching tagbody hasn't ended yet.
+   *
+   * This version is used by the compiler.
+   */
+  public static final LispObject nonLocalGo(LispObject tagbody,
+                                            LispObject tag)
+    throws ConditionThrowable
+  {
+    if (tagbody == null)
+      return error(new ControlError("Unmatched tag "
+                                    + tag.writeToString() +
+                                    " for GO outside lexical extent."));
+
+    throw new Go(tagbody, tag);
+  }
+
+  /** Throws a Go exception to cause a non-local transfer
+   * of control event, after checking that the extent of
+   * the catching tagbody hasn't ended yet.
+   *
+   * This version is used by the interpreter.
+   */
+  public static final LispObject nonLocalGo(Binding binding,
+                                            LispObject tag)
+    throws ConditionThrowable
+  {
+    if (binding.env.inactive)
+      return error(new ControlError("Unmatched tag "
+                                    + binding.symbol.writeToString() +
+                                    " for GO outside of lexical extent."));
+
+    throw new Go(binding.env, binding.symbol);
+  }
+
+  /** Throws a Return exception to cause a non-local transfer
+   * of control event, after checking that the extent of
+   * the catching block hasn't ended yet.
+   *
+   * This version is used by the compiler.
+   */
+  public static final LispObject nonLocalReturn(LispObject blockId,
+                                                LispObject blockName,
+                                                LispObject result)
+    throws ConditionThrowable
+  {
+    if (blockId == null)
+      return error(new ControlError("Unmatched block "
+                                    + blockName.writeToString() + " for " +
+                                    "RETURN-FROM outside lexical extent."));
+
+    throw new Return(blockId, result);
+  }
+
+  /** Throws a Return exception to cause a non-local transfer
+   * of control event, after checking that the extent of
+   * the catching block hasn't ended yet.
+   *
+   * This version is used by the interpreter.
+   */
+  public static final LispObject nonLocalReturn(Binding binding,
+                                                Symbol block,
+                                                LispObject result)
+    throws ConditionThrowable
+  {
+    if (binding == null)
+      {
+        return error(new LispError("No block named " + block.getName() +
+                                   " is currently visible."));
+      }
+
+    if (binding.env.inactive)
+      return error(new ControlError("Unmatched block "
+                                    + binding.symbol.writeToString() +
+                                    " for RETURN-FROM outside of" +
+                                    " lexical extent."));
+
+    throw new Return(binding.symbol, binding.value, result);
+  }
+
   public static final LispObject processTagBody(LispObject body,
                                                 LispObject localTags,
@@ -677 +758 @@
                         }
                     }
-                  throw new Go(binding.tagbody, tag);
+                  throw new Go(binding.env, tag);
                 }
               eval(current, env, thread);

trunk/abcl/src/org/armedbear/lisp/Primitives.java

@@ -3497 +3497 @@
       {
         Environment ext = new Environment(env);
-        return processTagBody(args, preprocessTagBody(args, ext), ext);
+        try {
+          return processTagBody(args, preprocessTagBody(args, ext), ext);
+        }
+        finally {
+          ext.inactive = true;
+        }
       }
     };
@@ -3516 +3521 @@
                                          args.car().writeToString() +
                                          " is currently visible."));
-        throw new Go(binding.tagbody, args.car());
+
+        return nonLocalGo(binding, args.car());
       }
     };
@@ -3550 +3556 @@
             throw ret;
           }
+        finally
+          {
+              ext.inactive = true;
+          }
       }
     };
@@ -3567 +3577 @@
             symbol = checkSymbol(args.car());
 
-        LispObject block = env.lookupBlock(symbol);
-        if (block == null)
-          {
-            FastStringBuffer sb = new FastStringBuffer("No block named ");
-            sb.append(symbol.getName());
-            sb.append(" is currently visible.");
-            error(new LispError(sb.toString()));
-          }
-        LispObject result;
-        if (length == 2)
-          result = eval(args.cadr(), env, LispThread.currentThread());
-        else
-          result = NIL;
-        throw new Return(symbol, block, result);
+        return nonLocalReturn(env.getBlockBinding(symbol), symbol,
+                              (length == 2) ? eval(args.cadr(), env,
+                                                   LispThread.currentThread())
+                                            : NIL);
       }
     };

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -4507 +4507 @@
       ; We need a handler to catch non-local GOs.
       (let* ((HANDLER (gensym))
+             (EXTENT-EXIT-HANDLER (gensym))
              (*register* *register*)
              (go-register (allocate-register))
@@ -4533 +4534 @@
                   +lisp-object+)
             (emit 'if_acmpne NEXT) ;; Jump if not EQ.
-            ;; Restore dynamic environment.
             (emit 'goto (tag-label tag))
             (label NEXT)))
@@ -4539 +4539 @@
         (label RETHROW)
         (aload go-register)
+        (emit 'aconst_null) ;; load null value
+        (emit-move-to-variable (tagbody-id-variable block))
+        (emit 'athrow)
+        (label EXTENT-EXIT-HANDLER)
+        (emit 'aconst_null) ;; load null value
+        (emit-move-to-variable (tagbody-id-variable block))
         (emit 'athrow)
         ;; Finally...
@@ -4545 +4551 @@
                             :code HANDLER
                             :catch-type (pool-class +lisp-go-class+))
+              *handlers*)
+        (push (make-handler :from BEGIN-BLOCK
+                            :to END-BLOCK
+                            :code EXTENT-EXIT-HANDLER
+                            :catch-type 0)
               *handlers*)))
     (label EXIT)
+    (when (tagbody-non-local-go-p block)
+      (emit 'aconst_null) ;; load null value
+      (emit-move-to-variable (tagbody-id-variable block)))
     (when must-clear-values
       (emit-clear-values))
@@ -4552 +4566 @@
     (when target
       (emit-push-nil)
-      (emit-move-from-stack target))))
+      (emit-move-from-stack target)))
+  )
 
 (defknown p2-go (t t t) t)
 (defun p2-go (form target representation)
   ;; FIXME What if we're called with a non-NIL representation?
-  (declare (ignore representation))
+  (declare (ignore target representation))
   (let* ((name (cadr form))
          (tag (find-tag name))
@@ -4575 +4590 @@
       (return-from p2-go))
     ;; Non-local GO.
-    (emit 'new +lisp-go-class+)
-    (emit 'dup)
-    (emit-push-variable (tagbody-id-variable (tag-block tag)))
-    (compile-form `',(tag-label tag) 'stack nil) ; Tag.
-    (emit-invokespecial-init +lisp-go-class+ (lisp-object-arg-types 2))
-    (emit 'athrow)
+    (emit-push-variable (tagbody-id-variable tag-block))
+    (emit 'getstatic *this-class*
+          (if *file-compilation*
+              (declare-object-as-string (tag-label tag))
+              (declare-object (tag-label tag)))
+          +lisp-object+) ; Tag.
+    (emit-invokestatic +lisp-class+ "nonLocalGo" (lisp-object-arg-types 2)
+                       +lisp-object+)
     ;; Following code will not be reached, but is needed for JVM stack
     ;; consistency.
-    (when target
-      (emit-push-nil)
-      (emit-move-from-stack target))))
+    (emit 'areturn)))
 
 (defknown p2-atom (t t t) t)
@@ -4692 +4707 @@
       (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one
       (let ((HANDLER (gensym))
+            (EXTENT-EXIT-HANDLER (gensym))
             (THIS-BLOCK (gensym)))
         (label HANDLER)
@@ -4700 +4716 @@
         ;; If it's not the block we're looking for...
         (emit 'if_acmpeq THIS-BLOCK) ; Stack depth is 1.
+        (label EXTENT-EXIT-HANDLER)
         ;; Not the tag we're looking for.
+        (emit 'aconst_null) ;; load null value
+        (emit-move-to-variable (block-id-variable block))
         (emit 'athrow)
         (label THIS-BLOCK)
@@ -4710 +4729 @@
                             :code HANDLER
                             :catch-type (pool-class +lisp-return-class+))
+              *handlers*)
+        (push (make-handler :from BEGIN-BLOCK
+                            :to END-BLOCK
+                            :code EXTENT-EXIT-HANDLER
+                            :catch-type 0)
               *handlers*)))
     (label BLOCK-EXIT)
+    (when (block-id-variable block)
+      (emit 'aconst_null) ;; load null value
+      (emit-move-to-variable (block-id-variable block)))
     (fix-boxing representation nil)))
 
@@ -4717 +4744 @@
 (defun p2-return-from (form target representation)
   ;; FIXME What if we're called with a non-NIL representation?
-  (declare (ignore representation))
+  (declare (ignore target representation))
   (let* ((name (second form))
          (result-form (third form))
@@ -4740 +4767 @@
     ;; Non-local RETURN.
     (aver (block-non-local-return-p block))
-    (cond ((node-constant-p result-form)
-           (emit 'new +lisp-return-class+)
-           (emit 'dup)
-           (emit-push-variable (block-id-variable block))
-           (emit-clear-values)
-           (compile-form result-form 'stack nil)) ; Result.
-          (t
-           (let* ((*register* *register*)
-                  (temp-register (allocate-register)))
-             (emit-clear-values)
-             (compile-form result-form temp-register nil) ; Result.
-             (emit 'new +lisp-return-class+)
-             (emit 'dup)
-             (emit-push-variable (block-id-variable block))
-             (aload temp-register))))
-    (emit-invokespecial-init +lisp-return-class+ (lisp-object-arg-types 2))
-    (emit 'athrow)
+    (emit-push-variable (block-id-variable block))
+    (emit 'getstatic *this-class*
+          (if *file-compilation*
+              (declare-object-as-string (block-name block))
+              (declare-object (block-name block)))
+          +lisp-object+)
+    (emit-clear-values)
+    (compile-form result-form 'stack nil)
+    (emit-invokestatic +lisp-class+ "nonLocalReturn" (lisp-object-arg-types 3)
+                       +lisp-object+)
     ;; Following code will not be reached, but is needed for JVM stack
     ;; consistency.
-    (when target
-      (emit-push-nil)
-      (emit-move-from-stack target))))
+    (emit 'areturn)))
 
 (defun emit-car/cdr (arg target representation field)

trunk/abcl/src/org/armedbear/lisp/dolist.java

@@ -59 +59 @@
 
     LispObject blockId = new LispObject();
+    final Environment ext = new Environment(env);
     try
       {
-        final Environment ext = new Environment(env);
         // Implicit block.
         ext.addBlock(NIL, blockId);
@@ -123 +123 @@
       {
         thread.lastSpecialBinding = lastSpecialBinding;
+        ext.inactive = true;
       }
   }

trunk/abcl/src/org/armedbear/lisp/dotimes.java

@@ -58 +58 @@
 
     LispObject blockId = new LispObject();
+    final Environment ext = new Environment(env);
     try
       {
-        Environment ext = new Environment(env);
         ext.addBlock(NIL, blockId);
 
@@ -149 +149 @@
       {
         thread.lastSpecialBinding = lastSpecialBinding;
+        ext.inactive = true;
       }
   }