[armedbear-cvs] r12698 - branches/less-reflection/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Mon May 17 18:53:43 UTC 2010
Author: astalla
Date: Mon May 17 14:53:41 2010
New Revision: 12698
Log:
Load class bytes on demand for disassemble.
Modified:
branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java
branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/disassemble.lisp
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java Mon May 17 14:53:41 2010
@@ -59,8 +59,7 @@
protected Class<?> findClass(String name) throws ClassNotFoundException {
try {
- Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls");
- byte[] b = readFunctionBytes(pathname);
+ byte[] b = getFunctionClassBytes(name);
return defineClass(name, b, 0, b.length);
} catch(Throwable e) { //TODO handle this better, readFunctionBytes uses Debug.assert() but should return null
e.printStackTrace();
@@ -69,6 +68,21 @@
}
}
+ public byte[] getFunctionClassBytes(String name) {
+ Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls");
+ return readFunctionBytes(pathname);
+ }
+
+ public byte[] getFunctionClassBytes(Class<?> functionClass) {
+ return getFunctionClassBytes(functionClass.getName());
+ }
+
+ public byte[] getFunctionClassBytes(Function f) {
+ byte[] b = getFunctionClassBytes(f.getClass());
+ f.setClassBytes(b);
+ return b;
+ }
+
public LispObject loadFunction(int fnNumber) {
try {
//Function name is fnIndex + 1
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java Mon May 17 14:53:41 2010
@@ -175,6 +175,34 @@
new JavaObject(bytes));
}
+ public final LispObject getClassBytes() {
+ LispObject o = getf(propertyList, Symbol.CLASS_BYTES, NIL);
+ if(o != NIL) {
+ return o;
+ } else {
+ ClassLoader c = getClass().getClassLoader();
+ if(c instanceof FaslClassLoader) {
+ return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this));
+ } else {
+ return NIL;
+ }
+ }
+ }
+
+ public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes();
+ public static final class pf_function_class_bytes extends Primitive {
+ public pf_function_class_bytes() {
+ super("function-class-bytes", PACKAGE_SYS, false, "function");
+ }
+ @Override
+ public LispObject execute(LispObject arg) {
+ if (arg instanceof Function) {
+ return ((Function) arg).getClassBytes();
+ }
+ return type_error(arg, Symbol.FUNCTION);
+ }
+ }
+
@Override
public LispObject execute()
{
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Mon May 17 14:53:41 2010
@@ -615,42 +615,7 @@
(%stream-terpri out)
(when (> *class-number* 0)
- (let* ((basename (base-classname))
- (expr `(lambda (fasl-loader fn-index)
- (identity fasl-loader) ;;to avoid unused arg
- ;;Ugly: should export & import JVM:: symbols
- (ecase fn-index
- ,@(loop
- :for i :from 1 :to *class-number*
- :collect
- (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)))
- `(,(1- i)
- (jvm::with-inline-code ()
- (jvm::emit 'jvm::aload 1)
- (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
- nil jvm::+java-object+)
- (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
- (jvm::emit 'jvm::dup)
- (jvm::emit-push-constant-int ,(1- i))
- (jvm::emit 'jvm::new ,class)
- (jvm::emit 'jvm::dup)
- (jvm::emit-invokespecial-init ,class '())
- (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
- (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
- (jvm::emit 'jvm::pop))
- t))))))
- (classname (fasl-loader-classname))
- (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls")
- *output-file-pathname*))))
- (jvm::with-saved-compiler-policy
- (jvm::with-file-compilation
- (with-open-file
- (f classfile
- :direction :output
- :element-type '(unsigned-byte 8)
- :if-exists :supersede)
- (jvm:compile-defun nil expr nil
- classfile f nil)))))
+ (generate-loader-function)
(write (list 'setq '*fasl-loader*
`(sys::make-fasl-class-loader
,*class-number*
@@ -700,6 +665,43 @@
(namestring output-file) elapsed))))
(values (truename output-file) warnings-p failure-p)))
+(defun generate-loader-function ()
+ (let* ((basename (base-classname))
+ (expr `(lambda (fasl-loader fn-index)
+ (identity fasl-loader) ;;to avoid unused arg
+ (ecase fn-index
+ ,@(loop
+ :for i :from 1 :to *class-number*
+ :collect
+ (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)))
+ `(,(1- i)
+ (jvm::with-inline-code ()
+ (jvm::emit 'jvm::aload 1)
+ (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
+ nil jvm::+java-object+)
+ (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
+ (jvm::emit 'jvm::dup)
+ (jvm::emit-push-constant-int ,(1- i))
+ (jvm::emit 'jvm::new ,class)
+ (jvm::emit 'jvm::dup)
+ (jvm::emit-invokespecial-init ,class '())
+ (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
+ (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
+ (jvm::emit 'jvm::pop))
+ t))))))
+ (classname (fasl-loader-classname))
+ (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls")
+ *output-file-pathname*))))
+ (jvm::with-saved-compiler-policy
+ (jvm::with-file-compilation
+ (with-open-file
+ (f classfile
+ :direction :output
+ :element-type '(unsigned-byte 8)
+ :if-exists :supersede)
+ (jvm:compile-defun nil expr nil
+ classfile f nil))))))
+
(defun compile-file-if-needed (input-file &rest allargs &key force-compile
&allow-other-keys)
(setf input-file (truename input-file))
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/disassemble.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/disassemble.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/disassemble.lisp Mon May 17 14:53:41 2010
@@ -47,14 +47,15 @@
(when (functionp function)
(unless (compiled-function-p function)
(setf function (compile nil function)))
- (when (getf (function-plist function) 'class-bytes)
- (with-input-from-string
- (stream (disassemble-class-bytes (getf (function-plist function) 'class-bytes)))
- (loop
- (let ((line (read-line stream nil)))
- (unless line (return))
- (write-string "; ")
- (write-string line)
- (terpri))))
- (return-from disassemble)))
- (%format t "; Disassembly is not available.~%")))
+ (let ((class-bytes (function-class-bytes function)))
+ (when class-bytes
+ (with-input-from-string
+ (stream (disassemble-class-bytes class-bytes))
+ (loop
+ (let ((line (read-line stream nil)))
+ (unless line (return))
+ (write-string "; ")
+ (write-string line)
+ (terpri))))
+ (return-from disassemble)))
+ (%format t "; Disassembly is not available.~%"))))
More information about the armedbear-cvs
mailing list