[armedbear-cvs] r13135 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Wed Jan 12 22:16:02 UTC 2011
Author: astalla
Date: Wed Jan 12 17:16:01 2011
New Revision: 13135
Log:
Revert to a reflection-based loading scheme for top-level compiled functions. Fix NPE in Package.java.
Modified:
trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java
trunk/abcl/src/org/armedbear/lisp/Package.java
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Wed Jan 12 17:16:01 2011
@@ -39,22 +39,12 @@
public class FaslClassLoader extends JavaClassLoader {
- private final LispObject[] functions;
private String baseName;
private LispObject loader; //The function used to load FASL functions by number
private final JavaObject boxedThis = new JavaObject(this);
-
- public FaslClassLoader(int functionCount, String baseName, boolean useLoaderFunction) {
- functions = new LispObject[functionCount];
- this.baseName = baseName;
- if(useLoaderFunction) {
- try {
- this.loader = (LispObject) loadClass(baseName + "_0").newInstance();
- } catch(Exception e) {
- //e.printStackTrace();
- Debug.trace("useLoaderFunction = true but couldn't fully init FASL loader ("+baseName+"), will fall back to reflection!");
- }
- }
+
+ public FaslClassLoader(String baseName) {
+ this.baseName = baseName;
}
@Override
@@ -90,81 +80,54 @@
@Override
protected Class<?> findClass(String name) throws ClassNotFoundException {
- try {
- 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();
- if(e instanceof ControlTransfer) { throw (ControlTransfer) e; }
- throw new ClassNotFoundException("Function class not found: " + name, e);
- }
+ try {
+ 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();
+ if(e instanceof ControlTransfer) { throw (ControlTransfer) e; }
+ throw new ClassNotFoundException("Function class not found: " + name, e);
+ }
}
public byte[] getFunctionClassBytes(String name) {
- Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls");
- return readFunctionBytes(pathname);
+ Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls");
+ return readFunctionBytes(pathname);
}
public byte[] getFunctionClassBytes(Class<?> functionClass) {
- return getFunctionClassBytes(functionClass.getName());
+ return getFunctionClassBytes(functionClass.getName());
}
public byte[] getFunctionClassBytes(Function f) {
- byte[] b = getFunctionClassBytes(f.getClass());
- f.setClassBytes(b);
- return b;
+ byte[] b = getFunctionClassBytes(f.getClass());
+ f.setClassBytes(b);
+ return b;
}
public LispObject loadFunction(int fnNumber) {
- try {
- //Function name is fnIndex + 1
- LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance();
- functions[fnNumber] = o;
- return o;
- } catch(Exception e) {
- e.printStackTrace();
- if(e instanceof ControlTransfer) { throw (ControlTransfer) e; }
- throw new RuntimeException(e);
- }
- }
-
- public LispObject getFunction(int fnNumber) {
- if(fnNumber >= functions.length) {
- return error(new LispError("Compiled function not found: " + baseName + "_" + (fnNumber + 1) + " " + Symbol.LOAD_TRUENAME.symbolValue()));
- }
- LispObject o = functions[fnNumber];
- if(o == null) {
- if(loader != null) {
- loader.execute(boxedThis, Fixnum.getInstance(fnNumber));
- return functions[fnNumber];
- } else { //Fallback to reflection
- return loadFunction(fnNumber);
- }
- } else {
- return o;
- }
- }
-
- public LispObject putFunction(int fnNumber, LispObject fn) {
- functions[fnNumber] = fn;
- return fn;
+ try {
+ //Function name is fnIndex + 1
+ LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance();
+ return o;
+ } catch(Exception e) {
+ if(e instanceof ControlTransfer) { throw (ControlTransfer) e; }
+ Debug.trace(e);
+ return error(new LispError("Compiled function can't be loaded: " + baseName + "_" + (fnNumber + 1) + " " + Symbol.LOAD_TRUENAME.symbolValue()));
+ }
}
private static final Primitive MAKE_FASL_CLASS_LOADER = new pf_make_fasl_class_loader();
private static final class pf_make_fasl_class_loader extends Primitive {
- pf_make_fasl_class_loader() {
- super("make-fasl-class-loader", PACKAGE_SYS, false, "function-count base-name");
+ pf_make_fasl_class_loader() {
+ super("make-fasl-class-loader", PACKAGE_SYS, false, "base-name");
}
@Override
- public LispObject execute(LispObject functionCount, LispObject baseName) {
- return execute(functionCount, baseName, T);
+ public LispObject execute(LispObject baseName) {
+ return new FaslClassLoader(baseName.getStringValue()).boxedThis;
}
- @Override
- public LispObject execute(LispObject functionCount, LispObject baseName, LispObject init) {
- return new FaslClassLoader(functionCount.intValue(), baseName.getStringValue(), init != NIL).boxedThis;
- }
};
private static final Primitive GET_FASL_FUNCTION = new pf_get_fasl_function();
@@ -176,7 +139,7 @@
@Override
public LispObject execute(LispObject loader, LispObject fnNumber) {
FaslClassLoader l = (FaslClassLoader) loader.javaInstance(FaslClassLoader.class);
- return l.getFunction(fnNumber.intValue());
+ return l.loadFunction(fnNumber.intValue());
}
};
Modified: trunk/abcl/src/org/armedbear/lisp/Package.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Package.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Package.java Wed Jan 12 17:16:01 2011
@@ -161,11 +161,13 @@
public final synchronized boolean delete()
{
if (name != null) {
- LispObject usedPackages = useList;
- while (usedPackages != NIL) {
- Package pkg = (Package) usedPackages.car();
- unusePackage(pkg);
- usedPackages = usedPackages.cdr();
+ if(useList instanceof Cons) {
+ LispObject usedPackages = useList;
+ while (usedPackages != NIL) {
+ Package pkg = (Package) usedPackages.car();
+ unusePackage(pkg);
+ usedPackages = usedPackages.cdr();
+ }
}
Packages.deletePackage(this);
Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Jan 12 17:16:01 2011
@@ -368,10 +368,8 @@
;; however, binding *load-truename* isn't fully compliant, I think.
(when compile-time-too
(let ((*load-truename* *output-file-pathname*)
- (*fasl-loader* (make-fasl-class-loader
- *class-number*
- (concatenate 'string "org.armedbear.lisp." (base-classname))
- nil)))
+ (*fasl-loader* (make-fasl-class-loader
+ (concatenate 'string "org.armedbear.lisp." (base-classname)))))
(eval form))))
(declaim (ftype (function (t) t) convert-ensure-method))
@@ -611,10 +609,8 @@
(%stream-terpri out)
(when (> *class-number* 0)
- (generate-loader-function)
(write (list 'setq '*fasl-loader*
`(sys::make-fasl-class-loader
- ,*class-number*
,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out))
(%stream-terpri out))
@@ -661,62 +657,6 @@
(namestring output-file) elapsed))))
(values (truename output-file) warnings-p failure-p)))
-(defmacro ncase (expr min max &rest clauses)
- "A CASE where all test clauses are numbers ranging from a minimum to a maximum."
- ;;Expr is subject to multiple evaluation, but since we only use ncase for
- ;;fn-index below, let's ignore it.
- (let* ((half (floor (/ (- max min) 2)))
- (middle (+ min half)))
- (if (> (- max min) 10)
- `(if (< ,expr ,middle)
- (ncase ,expr ,min ,middle ,@(subseq clauses 0 half))
- (ncase ,expr ,middle ,max ,@(subseq clauses half)))
- `(case ,expr , at clauses))))
-
-(defconstant +fasl-classloader+
- (jvm::make-jvm-class-name "org.armedbear.lisp.FaslClassLoader"))
-
-(defun generate-loader-function ()
- (let* ((basename (base-classname))
- (expr `(lambda (fasl-loader fn-index)
- (declare (type (integer 0 256000) fn-index))
- (identity fasl-loader) ;;to avoid unused arg
- (jvm::with-inline-code ()
- (jvm::emit 'jvm::aload 1)
- (jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance"
- nil jvm::+java-object+)
- (jvm::emit-checkcast +fasl-classloader+)
- (jvm::emit 'jvm::iload 2))
- (ncase fn-index 0 ,(1- *class-number*)
- ,@(loop
- :for i :from 1 :to *class-number*
- :collect
- (let* ((class (%format nil "org/armedbear/lisp/~A_~A"
- basename i))
- (class-name (jvm::make-jvm-class-name class)))
- `(,(1- i)
- (jvm::with-inline-code ()
- (jvm::emit-new ,class-name)
- (jvm::emit 'jvm::dup)
- (jvm::emit-invokespecial-init ,class-name '())
- (jvm::emit-invokevirtual +fasl-classloader+
- "putFunction"
- (list :int 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 *compile-file-environment*
- classfile f nil))))))
-
(defun compile-file-if-needed (input-file &rest allargs &key force-compile
&allow-other-keys)
(setf input-file (truename input-file))
More information about the armedbear-cvs
mailing list