Split StackFrame abstraction into Java and Lisp stack frames.

From the original patch/idea from Tobias Rittweiler this introduces
more information of primary interest to ABCL implemnters such as when
a form like (make-thread #'(lambda ())) is evaluated

All users of EXT:BACKTRACE-AS-LIST should now use SYS:BACKTRACE, the
results of which is a list of the new builtin classes JAVA_STACK_FRAME
or LISP_STACK_FRAME.  The methods SYS:FRAME-TO-STRING and
SYS:FRAME-TO-LIST are defined to break these new objects into
inspectable parts.  As a convenience, there is a SYS:BACKTRACE-AS-LIST
which calls SYS:FRAME-TO-LIST to each element of the computed
backtrace.

Refactorings have occurred on the Java side: the misnamed
LispThread.backtrace() is now LispThread.printBacktrace().
LispThread.backtraceAsList() is now LispThread.backtrace() as it is
a shorter name, and more to the point.

Java stack frames only appear after a call through Lisp.error(), which
has only the top level as a restart as an option.
parent 21074a5c
......@@ -142,6 +142,10 @@ public class BuiltInClass extends LispClass
public static final BuiltInClass THREAD = addClass(Symbol.THREAD);
public static final BuiltInClass TWO_WAY_STREAM = addClass(Symbol.TWO_WAY_STREAM);
public static final BuiltInClass VECTOR = addClass(Symbol.VECTOR);
public static final BuiltInClass STACK_FRAME = addClass(Symbol.STACK_FRAME);
public static final BuiltInClass LISP_STACK_FRAME = addClass(Symbol.LISP_STACK_FRAME);
public static final BuiltInClass JAVA_STACK_FRAME = addClass(Symbol.JAVA_STACK_FRAME);
public static final StructureClass STRUCTURE_OBJECT =
new StructureClass(Symbol.STRUCTURE_OBJECT, list(CLASS_T));
......@@ -275,6 +279,12 @@ public class BuiltInClass extends LispClass
TWO_WAY_STREAM.setCPL(TWO_WAY_STREAM, STREAM, CLASS_T);
VECTOR.setDirectSuperclasses(list(ARRAY, SEQUENCE));
VECTOR.setCPL(VECTOR, ARRAY, SEQUENCE, CLASS_T);
STACK_FRAME.setDirectSuperclasses(CLASS_T);
STACK_FRAME.setCPL(STACK_FRAME, CLASS_T);
LISP_STACK_FRAME.setDirectSuperclasses(STACK_FRAME);
LISP_STACK_FRAME.setCPL(LISP_STACK_FRAME, STACK_FRAME, CLASS_T);
JAVA_STACK_FRAME.setDirectSuperclasses(STACK_FRAME);
JAVA_STACK_FRAME.setCPL(JAVA_STACK_FRAME, STACK_FRAME, CLASS_T);
}
static
......
......@@ -389,7 +389,7 @@ public final class Interpreter extends Lisp
catch (Throwable t) {
getStandardInput().clearInput();
out.printStackTrace(t);
thread.backtrace();
thread.printBacktrace();
}
}
}
......@@ -408,7 +408,7 @@ public final class Interpreter extends Lisp
out._writeLine("Error: unhandled condition: " +
condition.writeToString());
if (thread != null)
thread.backtrace();
thread.printBacktrace();
}
catch (Throwable t) {
......
/*
* JavaStackFrame.java
*
* Copyright (C) 2009 Mark Evenson
* $Id$
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*
* As a special exception, the copyright holders of this library give you
* permission to link this library with independent modules to produce an
* executable, regardless of the license terms of these independent
* modules, and to copy and distribute the resulting executable under
* terms of your choice, provided that you also meet, for each linked
* independent module, the terms and conditions of the license of that
* module. An independent module is a module which is not derived from
* or based on this library. If you modify this library, you may extend
* this exception to your version of the library, but you are not
* obligated to do so. If you do not wish to do so, delete this
* exception statement from your version.
*/
package org.armedbear.lisp;
public class JavaStackFrame
extends StackFrame
{
public final StackTraceElement javaFrame;
public JavaStackFrame(StackTraceElement javaFrame)
{
this.javaFrame = javaFrame;
}
@Override
public LispObject typeOf() {
return Symbol.JAVA_STACK_FRAME;
}
@Override
public LispObject classOf() { return BuiltInClass.JAVA_STACK_FRAME; }
@Override
public String writeToString() {
String result = null;
final String JAVA_STACK_FRAME = "JAVA-STACK-FRAME";
try {
result = unreadableString(JAVA_STACK_FRAME + " "
+ toLispString().toString());
} catch (ConditionThrowable t) {
Debug.trace("Implementation error: ");
Debug.trace(t);
result = unreadableString(JAVA_STACK_FRAME);
}
return result;
}
@Override
public LispObject typep(LispObject typeSpecifier)
throws ConditionThrowable
{
if (typeSpecifier == Symbol.JAVA_STACK_FRAME)
return T;
if (typeSpecifier == BuiltInClass.JAVA_STACK_FRAME)
return T;
return super.typep(typeSpecifier);
}
static final Symbol CLASS = Packages.internKeyword("CLASS");
static final Symbol METHOD = Packages.internKeyword("METHOD");
static final Symbol FILE = Packages.internKeyword("FILE");
static final Symbol LINE = Packages.internKeyword("LINE");
static final Symbol NATIVE_METHOD = Packages.internKeyword("NATIVE-METHOD");
public LispObject toLispList() throws ConditionThrowable
{
LispObject result = Lisp.NIL;
if ( javaFrame == null)
return result;
result = result.push(CLASS);
result = result.push(new SimpleString(javaFrame.getClassName()));
result = result.push(METHOD);
result = result.push(new SimpleString(javaFrame.getMethodName()));
result = result.push(FILE);
result = result.push(new SimpleString(javaFrame.getFileName()));
result = result.push(LINE);
result = result.push(Fixnum.getInstance(javaFrame.getLineNumber()));
if (javaFrame.isNativeMethod()) {
result = result.push(NATIVE_METHOD);
result = result.push(Symbol.T);
}
return result.nreverse();
}
@Override
public SimpleString toLispString()
throws ConditionThrowable
{
return new SimpleString(javaFrame.toString());
}
@Override
public LispObject getParts()
throws ConditionThrowable
{
LispObject result = NIL;
result = result.push(new Cons("CLASS",
new SimpleString(javaFrame.getClassName())));
result = result.push(new Cons("METHOD",
new SimpleString(javaFrame.getMethodName())));
result = result.push(new Cons("FILE",
new SimpleString(javaFrame.getFileName())));
result = result.push(new Cons("LINE",
Fixnum.getInstance(javaFrame.getLineNumber())));
result = result.push(new Cons("NATIVE-METHOD",
LispObject.getInstance(javaFrame.isNativeMethod())));
return result.nreverse();
}
}
......@@ -271,7 +271,7 @@ public abstract class Lisp
catch (StackOverflowError e)
{
thread.setSpecialVariable(_SAVED_BACKTRACE_,
thread.backtraceAsList(0));
thread.backtrace(0));
return error(new StorageCondition("Stack overflow."));
}
catch (Go go)
......@@ -287,7 +287,7 @@ public abstract class Lisp
{
Debug.trace(t);
thread.setSpecialVariable(_SAVED_BACKTRACE_,
thread.backtraceAsList(0));
thread.backtrace(0));
return error(new LispError("Caught " + t + "."));
}
Debug.assertTrue(result != null);
......@@ -320,15 +320,39 @@ public abstract class Lisp
}
};
private static final void pushJavaStackFrames() throws ConditionThrowable
{
final LispThread thread = LispThread.currentThread();
final StackTraceElement[] frames = thread.getJavaStackTrace();
// Search for last Primitive in the StackTrace; that was the
// last entry point from Lisp.
int last = frames.length - 1;
for (int i = 0; i<= last; i++) {
if (frames[i].getClassName().startsWith("org.armedbear.lisp.Primitive"))
last = i;
}
// Do not include the first three frames:
// Thread.getStackTrace, LispThread.getJavaStackTrace,
// Lisp.pushJavaStackFrames.
while (last > 2) {
thread.pushStackFrame(new JavaStackFrame(frames[last]));
last--;
}
}
public static final LispObject error(LispObject condition)
throws ConditionThrowable
{
pushJavaStackFrames();
return Symbol.ERROR.execute(condition);
}
public static final LispObject error(LispObject condition, LispObject message)
throws ConditionThrowable
{
pushJavaStackFrames();
return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message);
}
......@@ -852,6 +876,14 @@ public abstract class Lisp
type_error(obj, Symbol.SINGLE_FLOAT);
}
public static final StackFrame checkStackFrame(LispObject obj)
throws ConditionThrowable
{
if (obj instanceof StackFrame)
return (StackFrame) obj;
return (StackFrame)// Not reached.
type_error(obj, Symbol.STACK_FRAME);
}
static
{
......
/*
* LispStackFrame.java
*
* Copyright (C) 2009 Mark Evenson
* $Id$
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*
* As a special exception, the copyright holders of this library give you
* permission to link this library with independent modules to produce an
* executable, regardless of the license terms of these independent
* modules, and to copy and distribute the resulting executable under
* terms of your choice, provided that you also meet, for each linked
* independent module, the terms and conditions of the license of that
* module. An independent module is a module which is not derived from
* or based on this library. If you modify this library, you may extend
* this exception to your version of the library, but you are not
* obligated to do so. If you do not wish to do so, delete this
* exception statement from your version.
*/
package org.armedbear.lisp;
public class LispStackFrame
extends StackFrame
{
public final LispObject operator;
private final LispObject first;
private final LispObject second;
private final LispObject third;
private final LispObject[] args;
public LispStackFrame(LispObject operator)
{
this.operator = operator;
first = null;
second = null;
third = null;
args = null;
}
public LispStackFrame(LispObject operator, LispObject arg)
{
this.operator = operator;
first = arg;
second = null;
third = null;
args = null;
}
public LispStackFrame(LispObject operator, LispObject first,
LispObject second)
{
this.operator = operator;
this.first = first;
this.second = second;
third = null;
args = null;
}
public LispStackFrame(LispObject operator, LispObject first,
LispObject second, LispObject third)
{
this.operator = operator;
this.first = first;
this.second = second;
this.third = third;
args = null;
}
public LispStackFrame(LispObject operator, LispObject... args)
{
this.operator = operator;
first = null;
second = null;
third = null;
final int length = args.length;
this.args = new LispObject[length];
System.arraycopy(args, 0, this.args, 0, length);
}
@Override
public LispObject typeOf() {
return Symbol.LISP_STACK_FRAME;
}
@Override
public LispObject classOf() {
return BuiltInClass.LISP_STACK_FRAME;
}
@Override
public String writeToString()
{
String result = "";
final String LISP_STACK_FRAME = "LISP-STACK-FRAME";
try {
result = unreadableString(LISP_STACK_FRAME + " "
+ toLispString().getStringValue());
} catch (ConditionThrowable t) {
Debug.trace("Implementation error: ");
Debug.trace(t);
result = unreadableString(LISP_STACK_FRAME);
}
return result;
}
@Override
public LispObject typep(LispObject typeSpecifier)
throws ConditionThrowable
{
if (typeSpecifier == Symbol.LISP_STACK_FRAME)
return T;
if (typeSpecifier == BuiltInClass.LISP_STACK_FRAME)
return T;
return super.typep(typeSpecifier);
}
public LispObject toLispList()
throws ConditionThrowable
{
LispObject result = argsToLispList();
if (operator instanceof Operator) {
LispObject lambdaName = ((Operator)operator).getLambdaName();
if (lambdaName != null && lambdaName != Lisp.NIL)
return result.push(lambdaName);
}
return result.push(operator);
}
private LispObject argsToLispList()
throws ConditionThrowable
{
LispObject result = Lisp.NIL;
if (args != null) {
for (int i = 0; i < args.length; i++)
result = result.push(args[i]);
} else {
do {
if (first != null)
result = result.push(first);
else
break;
if (second != null)
result = result.push(second);
else
break;
if (third != null)
result = result.push(third);
else
break;
} while (false);
}
return result.nreverse();
}
public SimpleString toLispString()
throws ConditionThrowable
{
return new SimpleString(toLispList().writeToString());
}
public LispObject getOperator() {
return operator;
}
@Override
public LispObject getParts()
throws ConditionThrowable
{
LispObject result = NIL;
result = result.push(new Cons("OPERATOR", getOperator()));
LispObject args = argsToLispList();
if (args != NIL) {
result = result.push(new Cons("ARGS", args));
}
return result.nreverse();
}
}
This diff is collapsed.
/*
* StackFrame.java
*
* Copyright (C) 2009 Mark Evenson
* $Id$
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*
* As a special exception, the copyright holders of this library give you
* permission to link this library with independent modules to produce an
* executable, regardless of the license terms of these independent
* modules, and to copy and distribute the resulting executable under
* terms of your choice, provided that you also meet, for each linked
* independent module, the terms and conditions of the license of that
* module. An independent module is a module which is not derived from
* or based on this library. If you modify this library, you may extend
* this exception to your version of the library, but you are not
* obligated to do so. If you do not wish to do so, delete this
* exception statement from your version.
*/
package org.armedbear.lisp;
public abstract class StackFrame
extends LispObject
{
@Override
public LispObject typep(LispObject typeSpecifier)
throws ConditionThrowable
{
if (typeSpecifier == Symbol.STACK_FRAME)
return T;
if (typeSpecifier == BuiltInClass.STACK_FRAME)
return T;
return super.typep(typeSpecifier);
}
StackFrame next;
void setNext(StackFrame nextFrame) {
this.next = nextFrame;
}
StackFrame getNext() {
return this.next;
}
public abstract LispObject toLispList() throws ConditionThrowable;
public abstract SimpleString toLispString() throws ConditionThrowable;
}
......@@ -3039,6 +3039,12 @@ public class Symbol extends LispObject
PACKAGE_SYS.addInternalSymbol("STRING-INPUT-STREAM");
public static final Symbol STRING_OUTPUT_STREAM =
PACKAGE_SYS.addInternalSymbol("STRING-OUTPUT-STREAM");
public static final Symbol STACK_FRAME =
PACKAGE_SYS.addInternalSymbol("STACK-FRAME");
public static final Symbol LISP_STACK_FRAME =
PACKAGE_SYS.addInternalSymbol("LISP-STACK-FRAME");
public static final Symbol JAVA_STACK_FRAME =
PACKAGE_SYS.addInternalSymbol("JAVA-STACK-FRAME");
// CDR6
public static final Symbol _INSPECTOR_HOOK_ =
......
......@@ -334,7 +334,6 @@
(load-system-file "defsetf")
(load-system-file "package")
(defun preload-package (pkg)
(%format t "Preloading ~S~%" (find-package pkg))
(dolist (sym (package-symbols pkg))
......
......@@ -100,7 +100,7 @@
(simple-format *debug-io* " ~A~%" condition)))))
(defun invoke-debugger (condition)
(let ((*saved-backtrace* (backtrace-as-list)))
(let ((*saved-backtrace* (sys:backtrace)))
(when *debugger-hook*
(let ((hook-function *debugger-hook*)
(*debugger-hook* nil))
......@@ -129,3 +129,7 @@
(list :format-control format-control
:format-arguments format-arguments))))
nil))
(defun backtrace-as-list (&optional (n 0))
"Return BACKTRACE with each element converted to a list."
(mapcar #'sys::frame-to-list (sys:backtrace n)))
......@@ -49,7 +49,7 @@
(let* ((old-bos *break-on-signals*)
(*break-on-signals* nil))
(when (typep condition old-bos)
(let ((*saved-backtrace* (backtrace-as-list)))
(let ((*saved-backtrace* (sys:backtrace)))
(break "~A~%BREAK called because of *BREAK-ON-SIGNALS* (now rebound to NIL)."
condition))))
(loop
......
......@@ -102,6 +102,23 @@
(%format *debug-io* "~A~%" s))
(show-restarts (compute-restarts) *debug-io*)))
(defun print-frame (frame stream &key prefix)
(when prefix
(write-string prefix stream))
(etypecase frame
(sys::lisp-stack-frame
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
(setq frame (sys:frame-to-list frame))
(ignore-errors
(prin1 (car frame) stream)
(let ((args (cdr frame)))
(if (listp args)
(format stream "~{ ~_~S~}" args)
(format stream " ~S" args))))))
(sys::java-stack-frame
(write-string (sys:frame-to-string frame) stream))))
(defun backtrace-command (args)
(let ((count (or (and args (ignore-errors (parse-integer args)))
8))
......@@ -113,14 +130,7 @@
(*print-array* nil))
(dolist (frame *saved-backtrace*)
(fresh-line *debug-io*)
(let ((prefix (format nil "~3D: (" n)))
(pprint-logical-block (*debug-io* nil :prefix prefix :suffix ")")
(ignore-errors
(prin1 (car frame) *debug-io*)
(let ((args (cdr frame)))
(if (listp args)
(format *debug-io* "~{ ~_~S~}" args)
(format *debug-io* " ~S" args))))))
(print-frame frame *debug-io* :prefix (format nil "~3D: " n))
(incf n)
(when (>= n count)
(return))))))
......@@ -136,12 +146,7 @@
(*print-readably* nil)
(*print-structure* nil))
(fresh-line *debug-io*)
(pprint-logical-block (*debug-io* nil :prefix "(" :suffix ")")
(prin1 (car frame) *debug-io*)
(let ((args (cdr frame)))
(if (listp args)
(format *debug-io* "~{ ~_~S~}" args)
(format *debug-io* " ~S" args))))))
(print-frame frame *debug-io*)))
(setf *** **
** *
* frame)))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment