[armedbear-cvs] r12170 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun Oct 4 12:37:33 UTC 2009
Author: ehuelsmann
Date: Sun Oct 4 08:37:29 2009
New Revision: 12170
Log:
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.
Modified:
trunk/abcl/src/org/armedbear/lisp/Binding.java
trunk/abcl/src/org/armedbear/lisp/Do.java
trunk/abcl/src/org/armedbear/lisp/Environment.java
trunk/abcl/src/org/armedbear/lisp/Lisp.java
trunk/abcl/src/org/armedbear/lisp/Primitives.java
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/dolist.java
trunk/abcl/src/org/armedbear/lisp/dotimes.java
Modified: trunk/abcl/src/org/armedbear/lisp/Binding.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Binding.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Binding.java Sun Oct 4 08:37:29 2009
@@ -47,11 +47,11 @@
*/
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.
*
@@ -81,10 +81,10 @@
this.next = next;
}
- Binding(LispObject symbol, LispObject tagbody,
+ Binding(LispObject symbol, Environment env,
LispObject value, Binding next)
{
this(symbol, value, next);
- this.tagbody = tagbody;
+ this.env = env;
}
}
Modified: trunk/abcl/src/org/armedbear/lisp/Do.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Do.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Do.java Sun Oct 4 08:37:29 2009
@@ -198,6 +198,7 @@
finally
{
thread.lastSpecialBinding = lastSpecialBinding;
+ ext.inactive = true;
}
}
}
Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Environment.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Environment.java Sun Oct 4 08:37:29 2009
@@ -39,6 +39,7 @@
private FunctionBinding lastFunctionBinding;
private Binding blocks;
private Binding tags;
+ public boolean inactive; //default value: false == active
public Environment() {}
@@ -165,9 +166,9 @@
return null;
}
- public void addBlock(LispObject tag, LispObject block)
+ public void addBlock(LispObject symbol, LispObject block)
{
- blocks = new Binding(tag, block, blocks);
+ blocks = new Binding(symbol, this, block, blocks);
}
public LispObject lookupBlock(LispObject symbol)
@@ -182,9 +183,21 @@
return null;
}
- public void addTagBinding(LispObject tag, LispObject tagbody, LispObject code)
+ public Binding getBlockBinding(LispObject block)
{
- tags = new Binding(tag, tagbody, code, tags);
+ 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);
}
public Binding getTagBinding(LispObject tag)
Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Oct 4 08:37:29 2009
@@ -644,6 +644,87 @@
return localTags;
}
+ /** 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,
Environment env)
@@ -676,7 +757,7 @@
continue;
}
}
- throw new Go(binding.tagbody, tag);
+ throw new Go(binding.env, tag);
}
eval(current, env, thread);
}
Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun Oct 4 08:37:29 2009
@@ -3496,7 +3496,12 @@
throws ConditionThrowable
{
Environment ext = new Environment(env);
- return processTagBody(args, preprocessTagBody(args, ext), ext);
+ try {
+ return processTagBody(args, preprocessTagBody(args, ext), ext);
+ }
+ finally {
+ ext.inactive = true;
+ }
}
};
@@ -3515,7 +3520,8 @@
return error(new ControlError("No tag named " +
args.car().writeToString() +
" is currently visible."));
- throw new Go(binding.tagbody, args.car());
+
+ return nonLocalGo(binding, args.car());
}
};
@@ -3549,6 +3555,10 @@
}
throw ret;
}
+ finally
+ {
+ ext.inactive = true;
+ }
}
};
@@ -3566,20 +3576,10 @@
Symbol symbol;
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);
}
};
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 Sun Oct 4 08:37:29 2009
@@ -4506,6 +4506,7 @@
(when (tagbody-non-local-go-p block)
; We need a handler to catch non-local GOs.
(let* ((HANDLER (gensym))
+ (EXTENT-EXIT-HANDLER (gensym))
(*register* *register*)
(go-register (allocate-register))
(tag-register (allocate-register)))
@@ -4532,31 +4533,45 @@
(declare-object (tag-label tag)))
+lisp-object+)
(emit 'if_acmpne NEXT) ;; Jump if not EQ.
- ;; Restore dynamic environment.
(emit 'goto (tag-label tag))
(label NEXT)))
;; Not found. Re-throw Go.
(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...
(push (make-handler :from BEGIN-BLOCK
:to END-BLOCK
: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))
;; TAGBODY returns NIL.
(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))
(tag-block (when tag (tag-block tag))))
@@ -4574,17 +4589,17 @@
(emit 'goto (tag-label tag))
(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)
(define-inlined-function p2-atom (form target representation)
@@ -4691,6 +4706,7 @@
;; We need a handler to catch non-local RETURNs.
(emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one
(let ((HANDLER (gensym))
+ (EXTENT-EXIT-HANDLER (gensym))
(THIS-BLOCK (gensym)))
(label HANDLER)
;; The Return object is on the runtime stack. Stack depth is 1.
@@ -4699,7 +4715,10 @@
(emit-push-variable (block-id-variable block))
;; 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)
(emit 'getfield +lisp-return-class+ "result" +lisp-object+)
@@ -4709,14 +4728,22 @@
:to END-BLOCK
: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)))
(defknown p2-return-from (t t t) t)
(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))
(block (find-block name)))
@@ -4739,28 +4766,19 @@
(return-from p2-return-from))))
;; 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)
(compile-forms-and-maybe-emit-clear-values arg 'stack nil)
Modified: trunk/abcl/src/org/armedbear/lisp/dolist.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/dolist.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/dolist.java Sun Oct 4 08:37:29 2009
@@ -58,9 +58,9 @@
bodyForm = bodyAndDecls.car();
LispObject blockId = new LispObject();
+ final Environment ext = new Environment(env);
try
{
- final Environment ext = new Environment(env);
// Implicit block.
ext.addBlock(NIL, blockId);
// Evaluate the list form.
@@ -122,6 +122,7 @@
finally
{
thread.lastSpecialBinding = lastSpecialBinding;
+ ext.inactive = true;
}
}
Modified: trunk/abcl/src/org/armedbear/lisp/dotimes.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/dotimes.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/dotimes.java Sun Oct 4 08:37:29 2009
@@ -57,9 +57,9 @@
bodyForm = bodyAndDecls.car();
LispObject blockId = new LispObject();
+ final Environment ext = new Environment(env);
try
{
- Environment ext = new Environment(env);
ext.addBlock(NIL, blockId);
LispObject limit = eval(countForm, ext, thread);
@@ -148,6 +148,7 @@
finally
{
thread.lastSpecialBinding = lastSpecialBinding;
+ ext.inactive = true;
}
}
More information about the armedbear-cvs
mailing list