[armedbear-cvs] r12672 - branches/less-reflection/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Wed May 12 22:52:35 UTC 2010
Author: astalla
Date: Wed May 12 18:52:33 2010
New Revision: 12672
Log:
FASL loader implemented. Has serious bugs (tests fail to compile), but can serve as a basis for further work.
Modified:
branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java
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/Interpreter.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java
branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java Wed May 12 18:52:33 2010
@@ -97,7 +97,7 @@
symbol.setSymbolFunction(new Autoload(symbol, null,
"org.armedbear.lisp.".concat(className)));
}
-
+
public void load()
{
if (className != null) {
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 Wed May 12 18:52:33 2010
@@ -38,7 +38,25 @@
import java.util.*;
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, will fall back to reflection!");
+ }
+ }
+ }
+
protected Class<?> findClass(String name) throws ClassNotFoundException {
try {
Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls");
@@ -51,13 +69,11 @@
}
}
- //TODO have compiler generate subclass, TEST ONLY!!!
- protected Map<String, LispObject> functions = new HashMap<String, LispObject>();
-
- public LispObject loadFunction(String className) {
+ public LispObject loadFunction(int fnNumber) {
try {
- LispObject o = (LispObject) loadClass(className).newInstance();
- functions.put(className, o);
+ //Function name is fnIndex + 1
+ LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance();
+ functions[fnNumber] = o;
return o;
} catch(Exception e) {
e.printStackTrace();
@@ -66,41 +82,55 @@
}
}
- public LispObject getFunction(final String className) {
- LispObject o = functions.get(className);
+ 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) {
- o = loadFunction(className);
+ if(loader != null) {
+ loader.execute(boxedThis, Fixnum.getInstance(fnNumber));
+ return functions[fnNumber];
+ } else { //Fallback to reflection
+ return loadFunction(fnNumber);
+ }
+ } else {
+ return o;
}
- return o;
}
- public static LispObject faslLoadFunction(String className) {
- FaslClassLoader cl = (FaslClassLoader) LispThread.currentThread().safeSymbolValue(_FASL_LOADER_).javaInstance();
- return cl.getFunction(className);
+ public LispObject putFunction(int fnNumber, LispObject fn) {
+ functions[fnNumber] = fn;
+ return fn;
}
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, "");
+ super("make-fasl-class-loader", PACKAGE_SYS, false, "function-count base-name");
+ }
+
+ @Override
+ public LispObject execute(LispObject functionCount, LispObject baseName) {
+ return execute(functionCount, baseName, T);
}
@Override
- public LispObject execute() {
- return new JavaObject(new FaslClassLoader());
+ 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();
private static final class pf_get_fasl_function extends Primitive {
pf_get_fasl_function() {
- super("get-fasl-function", PACKAGE_SYS, false, "loader class-name");
+ super("get-fasl-function", PACKAGE_SYS, false, "loader function-number");
}
@Override
- public LispObject execute(LispObject loader, LispObject className) {
+ public LispObject execute(LispObject loader, LispObject fnNumber) {
FaslClassLoader l = (FaslClassLoader) loader.javaInstance(FaslClassLoader.class);
- return l.getFunction("org.armedbear.lisp." + className.getStringValue());
+ return l.getFunction(fnNumber.intValue());
}
};
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 Wed May 12 18:52:33 2010
@@ -178,20 +178,20 @@
@Override
public LispObject execute()
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 0));
}
@Override
public LispObject execute(LispObject arg)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 1));
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 2));
}
@Override
@@ -199,7 +199,7 @@
LispObject third)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 3));
}
@Override
@@ -207,7 +207,7 @@
LispObject third, LispObject fourth)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 4));
}
@Override
@@ -216,7 +216,7 @@
LispObject fifth)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 5));
}
@Override
@@ -225,7 +225,7 @@
LispObject fifth, LispObject sixth)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 6));
}
@Override
@@ -235,7 +235,7 @@
LispObject seventh)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 7));
}
@Override
@@ -245,7 +245,7 @@
LispObject seventh, LispObject eighth)
{
- return error(new WrongNumberOfArgumentsException(this));
+ return error(new WrongNumberOfArgumentsException(this, 8));
}
@Override
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java Wed May 12 18:52:33 2010
@@ -281,6 +281,8 @@
sb.append(c.getCondition().writeToString());
sb.append(separator);
System.err.print(sb.toString());
+ System.err.println("backtrace: ");
+ evaluate("(princ (sys::backtrace))");
System.exit(2);
}
++i;
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java Wed May 12 18:52:33 2010
@@ -1243,6 +1243,7 @@
url = Lisp.class.getResource(name.getNamestring());
input = url.openStream();
} catch (IOException e) {
+ System.err.println("Failed to read class bytes from boot class " + url);
error(new LispError("Failed to read class bytes from boot class " + url));
}
}
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java Wed May 12 18:52:33 2010
@@ -252,6 +252,7 @@
}
}
+ private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*");
static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_");
public static final LispObject loadSystemFile(final String filename,
@@ -332,6 +333,7 @@
final LispThread thread = LispThread.currentThread();
final SpecialBindingsMark mark = thread.markSpecialBindings();
thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL);
+ thread.bindSpecial(FASL_LOADER, NIL);
try {
Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER);
return loadFileFromStream(pathname, truename, stream,
@@ -557,7 +559,7 @@
thread, Stream.currentReadtable);
if (obj == EOF)
break;
- result = eval(obj, env, thread);
+ result = eval(obj, env, thread);
if (print) {
Stream out =
checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread));
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 Wed May 12 18:52:33 2010
@@ -40,6 +40,14 @@
(defvar *output-file-pathname*)
+(defvar *function-packages* nil "An alist containing mappings (function-number . package). Every time an (IN-PACKAGE pkg) form is found at top-level, (*class-number* . pkg) is pushed onto this list.")
+
+(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
+ (sanitize-class-name (pathname-name output-file-pathname)))
+
+(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*))
+ (%format nil "~A_0" (base-classname output-file-pathname)))
+
(declaim (ftype (function (t) t) compute-classfile-name))
(defun compute-classfile-name (n &optional (output-file-pathname
*output-file-pathname*))
@@ -51,13 +59,14 @@
output-file-pathname))))
(defun sanitize-class-name (name)
- (dotimes (i (length name))
+ (let ((name (copy-seq name)))
+ (dotimes (i (length name))
(declare (type fixnum i))
(when (or (char= (char name i) #\-)
(char= (char name i) #\.)
(char= (char name i) #\Space))
(setf (char name i) #\_)))
- name)
+ name))
(declaim (ftype (function () t) next-classfile-name))
@@ -124,6 +133,8 @@
(return-from process-toplevel-form))
((IN-PACKAGE DEFPACKAGE)
(note-toplevel-form form)
+ (if (eq operator 'in-package)
+ (push (cons (1+ *class-number*) (cadr form)) *function-packages*))
(setf form (precompiler:precompile-form form nil *compile-file-environment*))
(eval form)
;; Force package prefix to be used when dumping form.
@@ -156,6 +167,7 @@
(parse-body body)
(let* ((expr `(lambda ,lambda-list
, at decls (block ,block-name , at body)))
+ (saved-class-number *class-number*)
(classfile (next-classfile-name))
(internal-compiler-errors nil)
(result (with-open-file
@@ -181,7 +193,7 @@
(setf form
`(fset ',name
(sys::get-fasl-function *fasl-loader*
- ,(pathname-name classfile))
+ ,saved-class-number)
; (proxy-preloaded-function ',name ,(file-namestring classfile))
,*source-position*
',lambda-list
@@ -239,6 +251,7 @@
(let ((name (second form)))
(eval form)
(let* ((expr (function-lambda-expression (macro-function name)))
+ (saved-class-number *class-number*)
(classfile (next-classfile-name)))
(with-open-file
(f classfile
@@ -258,13 +271,13 @@
;(proxy-preloaded-function
; '(macro-function ,name)
; ,(file-namestring classfile))
- (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile))))
+ (sys::get-fasl-function *fasl-loader* ,saved-class-number)))
`(fset ',name
(make-macro ',name
;(proxy-preloaded-function
; '(macro-function ,name)
; ,(file-namestring classfile))
- (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)))
+ (sys::get-fasl-function *fasl-loader* ,saved-class-number))
,*source-position*
',(third form)))))))))
(DEFTYPE
@@ -366,7 +379,10 @@
;; 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)))
+ (*fasl-loader* (make-fasl-class-loader
+ *class-number*
+ (concatenate 'string "org.armedbear.lisp." (base-classname))
+ nil)))
(eval form))))
(declaim (ftype (function (t) t) convert-ensure-method))
@@ -383,7 +399,8 @@
(eq (%car function-form) 'FUNCTION))
(let ((lambda-expression (cadr function-form)))
(jvm::with-saved-compiler-policy
- (let* ((classfile (next-classfile-name))
+ (let* ((saved-class-number *class-number*)
+ (classfile (next-classfile-name))
(result
(with-open-file
(f classfile
@@ -396,7 +413,7 @@
(declare (ignore result))
(cond (compiled-function
(setf (getf tail key)
- `(sys::get-fasl-function *fasl-loader* ,(pathname-name classfile))))
+ `(sys::get-fasl-function *fasl-loader* ,saved-class-number)))
;; `(load-compiled-function ,(file-namestring classfile))))
(t
;; FIXME This should be a warning or error of some sort...
@@ -430,6 +447,7 @@
(return-from convert-toplevel-form
(precompiler:precompile-form form nil *compile-file-environment*)))
(let* ((expr `(lambda () ,form))
+ (saved-class-number *class-number*)
(classfile (next-classfile-name))
(result
(with-open-file
@@ -443,7 +461,7 @@
(declare (ignore result))
(setf form
(if compiled-function
- `(funcall (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)));(load-compiled-function ,(file-namestring classfile)))
+ `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number))
(precompiler:precompile-form form nil *compile-file-environment*)))))
@@ -530,6 +548,7 @@
(*compile-file-truename* (truename in))
(*source* *compile-file-truename*)
(*class-number* 0)
+ (*function-packages* nil)
(namestring (namestring *compile-file-truename*))
(start (get-internal-real-time))
elapsed)
@@ -592,10 +611,57 @@
:stream out)
(%stream-terpri out)
- ;;TODO FAKE TEST ONLY!!!
(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
+ #|(let ((*package* *package*))
+ ,(let ((x (cdr (assoc 0 *function-packages*)))) ;;in-package before any function was defined
+ (when x
+ `(in-package ,(string x))))|#
+ (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::ldc (jvm::pool-string (symbol-name 'sys::*fasl-loader*)))
+ ;(jvm::emit 'jvm::ldc (jvm::pool-string (string :system)))
+ ;(jvm::emit-invokestatic jvm::+lisp-class+ "internInPackage"
+ ;(list jvm::+java-string+ jvm::+java-string+) jvm::+lisp-symbol+)
+ ;(jvm::emit-push-current-thread)
+ ; (jvm::emit-invokevirtual jvm::+lisp-symbol-class+ "symbolValue"
+ ; (list jvm::+lisp-thread+) jvm::+lisp-object+)
+ (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)))))
(write (list 'setq '*fasl-loader*
- '(sys::make-fasl-class-loader)) :stream out)
+ `(sys::make-fasl-class-loader
+ ,*class-number*
+ ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)
(%stream-terpri out))
#| (dump-form
`(dotimes (,count-sym ,*class-number*)
@@ -633,7 +699,8 @@
(zipfile (namestring
(merge-pathnames (make-pathname :type type)
output-file)))
- (pathnames ()))
+ (pathnames (list (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
+ output-file)))))
(dotimes (i *class-number*)
(let* ((pathname (compute-classfile-name (1+ i))))
(when (probe-file pathname)
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp Wed May 12 18:52:33 2010
@@ -958,7 +958,8 @@
(symbol-name symbol))
'precompiler))))
(unless (and handler (fboundp handler))
- (error "No handler for ~S." symbol))
+ (error "No handler for ~S." (let ((*package* (find-package :keyword)))
+ (format nil "~S" symbol))))
(setf (get symbol 'precompile-handler) handler)))
(defun install-handlers ()
More information about the armedbear-cvs
mailing list