[armedbear-devel] [armedbear-cvs] r12742 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
alessiostalla at gmail.com
Wed Jun 9 07:21:02 UTC 2010
On Mon, Jun 7, 2010 at 8:43 PM, Erik Huelsmann <ehuels at gmail.com> wrote:
> Hi Alessio, Nice work!
Thanks, and sorry for not announcing this to the ML. I did it more or
less in a hurry (don't worry though - I ran the test suite before the
commit ;)
> On Mon, Jun 7, 2010 at 8:30 PM, Alessio Stalla <astalla at common-lisp.net> wrote:
>> Author: astalla
>> Date: Mon Jun 7 14:30:36 2010
>> New Revision: 12742
>>
>> Log:
>> less-reflection branch merged with trunk. verify-load temporarily disabled.
>>
>>
>> Added:
>> trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java
>> - copied, changed from r12739, /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java
>> Modified:
>> trunk/abcl/src/org/armedbear/lisp/Autoload.java
>> trunk/abcl/src/org/armedbear/lisp/Function.java
>> trunk/abcl/src/org/armedbear/lisp/Lisp.java
>> trunk/abcl/src/org/armedbear/lisp/Load.java
>> trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
>> trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
>> trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
>> trunk/abcl/src/org/armedbear/lisp/disassemble.lisp
>> trunk/abcl/src/org/armedbear/lisp/gui.lisp
>> trunk/abcl/src/org/armedbear/lisp/load.lisp
>> trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
>> trunk/abcl/src/org/armedbear/lisp/proclaim.lisp
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Mon Jun 7 14:30:36 2010
>> @@ -97,7 +97,7 @@
>> symbol.setSymbolFunction(new Autoload(symbol, null,
>> "org.armedbear.lisp.".concat(className)));
>> }
>> -
>> +
>> public void load()
>> {
>> if (className != null) {
>> @@ -684,6 +684,9 @@
>>
>> autoload(Symbol.COPY_LIST, "copy_list");
>>
>> + autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false);
>> + autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false);
>> +
>> autoload(Symbol.SET_CHAR, "StringFunctions");
>> autoload(Symbol.SET_SCHAR, "StringFunctions");
>>
>>
>> Copied: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (from r12739, /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java)
>> ==============================================================================
>> --- /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Mon Jun 7 14:30:36 2010
>> @@ -70,7 +70,15 @@
>>
>> public byte[] getFunctionClassBytes(String name) {
>> Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls");
>> - return readFunctionBytes(pathname);
>> + final LispThread thread = LispThread.currentThread();
>> + SpecialBindingsMark mark = thread.markSpecialBindings();
>> + try {
>> + //thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, NIL);
>
> Maybe a code comment why this needs commenting out? Or maybe it was an
> unintended leftover?
It's an unintended leftover. In the branch no specials were rebound in
that point, but something changed in readFunctionBytes so that it now
uses *load-truename* (thus when loading, say, clos_123.cls it searches
for it in the wrong place if *load-truename* is non-NIL). I thought
that was true for *load-truename-fasl* too, but it turned out it
isn't, so I commented it out and forgot to remove it.
>
>> + thread.bindSpecial(Symbol.LOAD_TRUENAME, NIL);
>> + return readFunctionBytes(pathname);
>> + } finally {
>> + thread.resetSpecialBindings(mark);
>> + }
>> }
>>
>> public byte[] getFunctionClassBytes(Class<?> functionClass) {
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/Function.java
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/Function.java (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/Function.java Mon Jun 7 14:30:36 2010
>> @@ -175,23 +175,51 @@
>> 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()
>> {
>> - 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 +227,7 @@
>> LispObject third)
>>
>> {
>> - return error(new WrongNumberOfArgumentsException(this));
>> + return error(new WrongNumberOfArgumentsException(this, 3));
>> }
>>
>> @Override
>> @@ -207,7 +235,7 @@
>> LispObject third, LispObject fourth)
>>
>> {
>> - return error(new WrongNumberOfArgumentsException(this));
>> + return error(new WrongNumberOfArgumentsException(this, 4));
>> }
>>
>> @Override
>> @@ -216,7 +244,7 @@
>> LispObject fifth)
>>
>> {
>> - return error(new WrongNumberOfArgumentsException(this));
>> + return error(new WrongNumberOfArgumentsException(this, 5));
>> }
>>
>> @Override
>> @@ -225,7 +253,7 @@
>> LispObject fifth, LispObject sixth)
>>
>> {
>> - return error(new WrongNumberOfArgumentsException(this));
>> + return error(new WrongNumberOfArgumentsException(this, 6));
>> }
>>
>> @Override
>> @@ -235,7 +263,7 @@
>> LispObject seventh)
>>
>> {
>> - return error(new WrongNumberOfArgumentsException(this));
>> + return error(new WrongNumberOfArgumentsException(this, 7));
>> }
>>
>> @Override
>> @@ -245,7 +273,7 @@
>> LispObject seventh, LispObject eighth)
>>
>> {
>> - return error(new WrongNumberOfArgumentsException(this));
>> + return error(new WrongNumberOfArgumentsException(this, 8));
>> }
>>
>> @Override
>>
>> 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 Mon Jun 7 14:30:36 2010
>> @@ -43,8 +43,6 @@
>> import java.net.URL;
>> import java.net.URLDecoder;
>> import java.util.Hashtable;
>> -import java.util.zip.ZipEntry;
>> -import java.util.zip.ZipFile;
>>
>> public final class Lisp
>> {
>> @@ -1266,6 +1264,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);
>
> I understand this from a debugging point of view, but maybe we want to
> make sure ABCL doesn't crash hard if its unable to write to err, for
> whatever reason? (Like being in a Swing app without console stream
> bindings.)
Well, I never heard of a Java app crashing due to writing to
System.err, even in Swing you can write to the console, even if not
visible. That said, that System.err is another leftover for debugging
purposes and can be safely removed.
>> error(new LispError("Failed to read class bytes from boot class " + url));
>> }
>> }
>> @@ -2385,6 +2384,10 @@
>> public static final Symbol _LOAD_STREAM_ =
>> internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL);
>>
>> + // ### *fasl-loader*
>> + public static final Symbol _FASL_LOADER_ =
>> + exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL);
>> +
>> // ### *source*
>> // internal symbol
>> public static final Symbol _SOURCE_ =
>> @@ -2758,4 +2761,16 @@
>> Symbol.DEBUG_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true));
>> }
>>
>> + private static final SpecialOperator WITH_INLINE_CODE = new with_inline_code();
>> + private static class with_inline_code extends SpecialOperator {
>> + with_inline_code() {
>> + super("with-inline-code", PACKAGE_JVM, true, "(&optional target repr) &body body");
>> + }
>> + @Override
>> + public LispObject execute(LispObject args, Environment env)
>> + {
>> + return error(new SimpleError("This is a placeholder. It should only be called in compiled code, and tranformed by the compiler using special form handlers."));
>> + }
>> + }
>> +
>> }
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/Load.java
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/Load.java (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/Load.java Mon Jun 7 14:30:36 2010
>> @@ -242,6 +242,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,
>> @@ -268,7 +269,7 @@
>> String path = pathname.asEntryPath();
>> url = Lisp.class.getResource(path);
>> if (url == null || url.toString().endsWith("/")) {
>> - url = Lisp.class.getResource(path + ".abcl");
>> + url = Lisp.class.getResource(path.replace('-', '_') + ".abcl");
>> if (url == null) {
>> url = Lisp.class.getResource(path + ".lisp");
>> }
>> @@ -322,6 +323,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,
>> @@ -567,7 +569,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: 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 Mon Jun 7 14:30:36 2010
>> @@ -40,17 +40,33 @@
>>
>> (defvar *output-file-pathname*)
>>
>> +(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*))
>> "Computes the name of the class file associated with number `n'."
>> (let ((name
>> - (%format nil "~A-~D"
>> - (substitute #\_ #\.
>> - (pathname-name output-file-pathname)) n)))
>> + (sanitize-class-name
>> + (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
>> (namestring (merge-pathnames (make-pathname :name name :type "cls")
>> output-file-pathname))))
>>
>> +(defun sanitize-class-name (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))
>> +
>> +
>> (declaim (ftype (function () t) next-classfile-name))
>> (defun next-classfile-name ()
>> (compute-classfile-name (incf *class-number*)))
>> @@ -69,12 +85,14 @@
>>
>> (declaim (ftype (function (t) t) verify-load))
>> (defun verify-load (classfile)
>> - (if (> *safety* 0)
>> - (and classfile
>> + #|(if (> *safety* 0)
>> + (and classfile
>> (let ((*load-truename* *output-file-pathname*))
>> (report-error
>> (load-compiled-function classfile))))
>> - t))
>> + t)|#
>> + (declare (ignore classfile))
>> + t)
>>
>> (declaim (ftype (function (t) t) process-defconstant))
>> (defun process-defconstant (form)
>> @@ -144,6 +162,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
>> @@ -168,7 +187,8 @@
>> compiled-function)
>> (setf form
>> `(fset ',name
>> - (proxy-preloaded-function ',name ,(file-namestring classfile))
>> + (sys::get-fasl-function *fasl-loader*
>> + ,saved-class-number)
>> ,*source-position*
>> ',lambda-list
>> ,doc))
>> @@ -225,6 +245,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
>> @@ -241,14 +262,10 @@
>> (if (special-operator-p name)
>> `(put ',name 'macroexpand-macro
>> (make-macro ',name
>> - (proxy-preloaded-function
>> - '(macro-function ,name)
>> - ,(file-namestring 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* ,saved-class-number))
>> ,*source-position*
>> ',(third form)))))))))
>> (DEFTYPE
>> @@ -348,8 +365,12 @@
>> ;; to load the compiled functions. Note that this trickery
>> ;; was already used in verify-load before I used it,
>> ;; however, binding *load-truename* isn't fully compliant, I think.
>> - (let ((*load-truename* *output-file-pathname*))
>> - (when compile-time-too
>> + (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)))
>> (eval form))))
>>
>> (declaim (ftype (function (t) t) convert-ensure-method))
>> @@ -366,7 +387,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
>> @@ -379,7 +401,8 @@
>> (declare (ignore result))
>> (cond (compiled-function
>> (setf (getf tail key)
>> - `(load-compiled-function ,(file-namestring 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...
>> (format *error-output* "; Unable to compile method~%")))))))))
>> @@ -412,6 +435,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
>> @@ -425,7 +449,7 @@
>> (declare (ignore result))
>> (setf form
>> (if compiled-function
>> - `(funcall (load-compiled-function ,(file-namestring classfile)))
>> + `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number))
>> (precompiler:precompile-form form nil *compile-file-environment*)))))
>>
>>
>> @@ -572,25 +596,22 @@
>> (write (list 'setq '*source* *compile-file-truename*)
>> :stream out)
>> (%stream-terpri out)
>> - ;; Note: Beyond this point, you can't use DUMP-FORM,
>> - ;; because the list of uninterned symbols has been fixed now.
>> - (when *fasl-uninterned-symbols*
>> - (write (list 'setq '*fasl-uninterned-symbols*
>> - (coerce (mapcar #'car
>> - (nreverse *fasl-uninterned-symbols*))
>> - 'vector))
>> - :stream out))
>> - (%stream-terpri out)
>> - ;; we work with a fixed variable name here to work around the
>> - ;; lack of availability of the circle reader in the fasl reader
>> - ;; but it's a toplevel form anyway
>> - (write `(dotimes (i ,*class-number*)
>> - (function-preload
>> - (%format nil "~A-~D.cls"
>> - ,(substitute #\_ #\. (pathname-name output-file))
>> - (1+ i))))
>> - :stream out
>> - :circle t)
>> + ;; Note: Beyond this point, you can't use DUMP-FORM,
>> + ;; because the list of uninterned symbols has been fixed now.
>> + (when *fasl-uninterned-symbols*
>> + (write (list 'setq '*fasl-uninterned-symbols*
>> + (coerce (mapcar #'car
>> + (nreverse *fasl-uninterned-symbols*))
>> + 'vector))
>> + :stream out))
>> + (%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))
>>
>>
>> @@ -609,7 +630,11 @@
>> (zipfile (namestring
>> (merge-pathnames (make-pathname :type type)
>> output-file)))
>> - (pathnames ()))
>> + (pathnames nil)
>> + (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
>> + output-file))))
>> + (when (probe-file fasl-loader)
>> + (push fasl-loader pathnames))
>> (dotimes (i *class-number*)
>> (let* ((pathname (compute-classfile-name (1+ i))))
>> (when (probe-file pathname)
>> @@ -632,6 +657,55 @@
>> (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))))
>> +
>> +(defun generate-loader-function ()
>> + (let* ((basename (base-classname))
>> + (expr `(lambda (fasl-loader fn-index)
>> + (identity fasl-loader) ;;to avoid unused arg
>> + (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)))
>> + `(,(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: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Mon Jun 7 14:30:36 2010
>> @@ -1298,7 +1298,7 @@
>> (format t "; inlining call to local function ~S~%" op)))
>> (return-from p1-function-call
>> (let ((*inline-declarations*
>> - (remove op *inline-declarations* :key #'car)))
>> + (remove op *inline-declarations* :key #'car :test #'equal)))
>> (p1 expansion))))))
>>
>> ;; FIXME
>> @@ -1432,7 +1432,8 @@
>> (TRULY-THE p1-truly-the)
>> (UNWIND-PROTECT p1-unwind-protect)
>> (THREADS:SYNCHRONIZED-ON
>> - p1-threads-synchronized-on)))
>> + p1-threads-synchronized-on)
>> + (JVM::WITH-INLINE-CODE identity)))
>> (install-p1-handler (%car pair) (%cadr pair))))
>>
>> (initialize-p1-handlers)
>>
>> 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 Mon Jun 7 14:30:36 2010
>> @@ -198,6 +198,8 @@
>> (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
>> n)))
>>
>> +(defconstant +fasl-loader-class+
>> + "org/armedbear/lisp/FaslClassLoader")
>> (defconstant +java-string+ "Ljava/lang/String;")
>> (defconstant +java-object+ "Ljava/lang/Object;")
>> (defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
>> @@ -2267,12 +2269,22 @@
>> local-function *declared-functions* ht g
>> (setf g (symbol-name (gensym "LFUN")))
>> (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function)))
>> + (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname)))
>> (*code* *static-code*))
>> ;; fixme *declare-inline*
>> - (declare-field g +lisp-object+ +field-access-default+)
>> - (emit 'ldc (pool-string (file-namestring pathname)))
>> - (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction"
>> - (list +java-string+) +lisp-object+)
>> + (declare-field g +lisp-object+ +field-access-private+)
>> + (emit 'new class-name)
>> + (emit 'dup)
>> + (emit-invokespecial-init class-name '())
>> +
>> + ;(emit 'ldc (pool-string (pathname-name pathname)))
>> + ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction"
>> + ;(list +java-string+) +lisp-object+)
>> +
>> +; (emit 'ldc (pool-string (file-namestring pathname)))
>> +
>> +; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction"
>> +; (list +java-string+) +lisp-object+)
>> (emit 'putstatic *this-class* g +lisp-object+)
>> (setf *static-code* *code*)
>> (setf (gethash local-function ht) g))))
>> @@ -5094,7 +5106,8 @@
>> (local-function-function local-function)))))
>> (emit 'getstatic *this-class*
>> g +lisp-object+))))) ; Stack: template-function
>> - ((member name *functions-defined-in-current-file* :test #'equal)
>> + ((and (member name *functions-defined-in-current-file* :test #'equal)
>> + (not (notinline-p name)))
>> (emit 'getstatic *this-class*
>> (declare-setf-function name) +lisp-object+)
>> (emit-move-from-stack target))
>> @@ -7544,6 +7557,32 @@
>> ;; delay resolving the method to run-time; it's unavailable now
>> (compile-function-call form target representation))))
>>
>> +#|(defknown p2-java-jcall (t t t) t)
>> +(define-inlined-function p2-java-jcall (form target representation)
>> + ((and (> *speed* *safety*)
>> + (< 1 (length form))
>> + (eq 'jmethod (car (cadr form)))
>> + (every #'stringp (cdr (cadr form)))))
>> + (let ((m (ignore-errors (eval (cadr form)))))
>> + (if m
>> + (let ((must-clear-values nil)
>> + (arg-types (raw-arg-types (jmethod-params m))))
>> + (declare (type boolean must-clear-values))
>> + (dolist (arg (cddr form))
>> + (compile-form arg 'stack nil)
>> + (unless must-clear-values
>> + (unless (single-valued-p arg)
>> + (setf must-clear-values t))))
>> + (when must-clear-values
>> + (emit-clear-values))
>> + (dotimes (i (jarray-length raw-arg-types))
>> + (push (jarray-ref raw-arg-types i) arg-types))
>> + (emit-invokevirtual (jclass-name (jmethod-declaring-class m))
>> + (jmethod-name m)
>> + (nreverse arg-types)
>> + (jmethod-return-type m)))
>> + ;; delay resolving the method to run-time; it's unavailable now
>> + (compile-function-call form target representation))))|#
>
> Maybe this can use a comment on why it's commented out? Is this not a
> good idea? Does it depend on premises which are not (yet) met?
Ah, sorry. That wasn't intended to be there at all. It was a very
unfinished attempt to translate jcall to invokevirtual when all the
info to do so is known at compile-time. It has nothing to do with the
less-reflection branch, it just happened to be there by accident.
>>
>> (defknown p2-char= (t t t) t)
>> (defun p2-char= (form target representation)
>> @@ -8220,6 +8259,13 @@
>> (setf (method-handlers execute-method) (nreverse *handlers*)))
>> t)
>>
>> +(defun p2-with-inline-code (form target representation)
>> + ;;form = (with-inline-code (&optional target-var repr-var) ...body...)
>> + (destructuring-bind (&optional target-var repr-var) (cadr form)
>> + (eval `(let (,@(when target-var `((,target-var ,target)))
>> + ,@(when repr-var `((,repr-var ,representation))))
>> + ,@(cddr form)))))
>> +
>> (defun compile-1 (compiland stream)
>> (let ((*all-variables* nil)
>> (*closure-variables* nil)
>> @@ -8512,6 +8558,7 @@
>> (install-p2-handler 'java:jclass 'p2-java-jclass)
>> (install-p2-handler 'java:jconstructor 'p2-java-jconstructor)
>> (install-p2-handler 'java:jmethod 'p2-java-jmethod)
>> +; (install-p2-handler 'java:jcall 'p2-java-jcall)
>> (install-p2-handler 'char= 'p2-char=)
>> (install-p2-handler 'characterp 'p2-characterp)
>> (install-p2-handler 'coerce-to-function 'p2-coerce-to-function)
>> @@ -8596,6 +8643,7 @@
>> (install-p2-handler 'vector-push-extend 'p2-vector-push-extend)
>> (install-p2-handler 'write-8-bits 'p2-write-8-bits)
>> (install-p2-handler 'zerop 'p2-zerop)
>> + (install-p2-handler 'with-inline-code 'p2-with-inline-code)
>> t)
>>
>> (initialize-p2-handlers)
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/disassemble.lisp
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/disassemble.lisp (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/disassemble.lisp Mon Jun 7 14:30:36 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.~%"))))
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/gui.lisp
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/gui.lisp (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/gui.lisp Mon Jun 7 14:30:36 2010
>> @@ -1,5 +1,7 @@
>> (in-package :extensions)
>>
>> +(require :java)
>> +
>> (defvar *gui-backend* :swing)
>>
>> (defun init-gui ()
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/load.lisp
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/load.lisp (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/load.lisp Mon Jun 7 14:30:36 2010
>> @@ -38,10 +38,11 @@
>> (if-does-not-exist t)
>> (external-format :default))
>> (declare (ignore external-format)) ; FIXME
>> - (%load (if (streamp filespec)
>> - filespec
>> - (merge-pathnames (pathname filespec)))
>> - verbose print if-does-not-exist))
>> + (let (*fasl-loader*)
>> + (%load (if (streamp filespec)
>> + filespec
>> + (merge-pathnames (pathname filespec)))
>> + verbose print if-does-not-exist)))
>>
>> (defun load-returning-last-result (filespec
>> &key
>> @@ -50,7 +51,8 @@
>> (if-does-not-exist t)
>> (external-format :default))
>> (declare (ignore external-format)) ; FIXME
>> - (%load-returning-last-result (if (streamp filespec)
>> - filespec
>> - (merge-pathnames (pathname filespec)))
>> - verbose print if-does-not-exist))
>> \ No newline at end of file
>> + (let (*fasl-loader*)
>> + (%load-returning-last-result (if (streamp filespec)
>> + filespec
>> + (merge-pathnames (pathname filespec)))
>> + verbose print if-does-not-exist)))
>> \ No newline at end of file
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Mon Jun 7 14:30:36 2010
>> @@ -32,13 +32,10 @@
>> (in-package "SYSTEM")
>>
>>
>> -(export '(*inline-declarations*
>> - process-optimization-declarations
>> +(export '(process-optimization-declarations
>> inline-p notinline-p inline-expansion expand-inline
>> *defined-functions* *undefined-functions* note-name-defined))
>>
>> -(defvar *inline-declarations* nil)
>> -
>> (declaim (ftype (function (t) t) process-optimization-declarations))
>> (defun process-optimization-declarations (forms)
>> (dolist (form forms)
>> @@ -86,7 +83,7 @@
>> (declaim (ftype (function (t) t) inline-p))
>> (defun inline-p (name)
>> (declare (optimize speed))
>> - (let ((entry (assoc name *inline-declarations*)))
>> + (let ((entry (assoc name *inline-declarations* :test #'equal)))
>> (if entry
>> (eq (cdr entry) 'INLINE)
>> (and (symbolp name) (eq (get name '%inline) 'INLINE)))))
>> @@ -94,7 +91,7 @@
>> (declaim (ftype (function (t) t) notinline-p))
>> (defun notinline-p (name)
>> (declare (optimize speed))
>> - (let ((entry (assoc name *inline-declarations*)))
>> + (let ((entry (assoc name *inline-declarations* :test #'equal)))
>> (if entry
>> (eq (cdr entry) 'NOTINLINE)
>> (and (symbolp name) (eq (get name '%inline) 'NOTINLINE)))))
>> @@ -961,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 ()
>> @@ -1024,7 +1022,9 @@
>> (TRULY-THE precompile-truly-the)
>>
>> (THREADS:SYNCHRONIZED-ON
>> - precompile-threads-synchronized-on)))
>> + precompile-threads-synchronized-on)
>> +
>> + (JVM::WITH-INLINE-CODE precompile-identity)))
>> (install-handler (first pair) (second pair))))
>>
>> (install-handlers)
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/proclaim.lisp
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/proclaim.lisp (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/proclaim.lisp Mon Jun 7 14:30:36 2010
>> @@ -31,7 +31,7 @@
>>
>> (in-package #:system)
>>
>> -(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type))
>> +(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type *inline-declarations*))
>>
>> (defmacro declaim (&rest decls)
>> `(eval-when (:compile-toplevel :load-toplevel :execute)
>> @@ -43,6 +43,7 @@
>> :format-control "The symbol ~S cannot be both the name of a type and the name of a declaration."
>> :format-arguments (list name)))
>>
>> +(defvar *inline-declarations* nil)
>> (defvar *declaration-types* (make-hash-table :test 'eq))
>>
>> ;; "A symbol cannot be both the name of a type and the name of a declaration.
>> @@ -91,8 +92,9 @@
>> (apply 'proclaim-type (cdr declaration-specifier)))
>> ((INLINE NOTINLINE)
>> (dolist (name (cdr declaration-specifier))
>> - (when (symbolp name) ; FIXME Need to support non-symbol function names.
>> - (setf (get name '%inline) (car declaration-specifier)))))
>> + (if (symbolp name)
>> + (setf (get name '%inline) (car declaration-specifier))
>> + (push (cons name (car declaration-specifier)) *inline-declarations*))))
>> (DECLARATION
>> (dolist (name (cdr declaration-specifier))
>> (when (or (get name 'deftype-definition)
>
> Thanks again! I hope this helps us getting a common base for things
> happening in the FASL (such as constants and other stuff that we want
> to create/instantiate only once; not every function class by itself).
I hope so, too. And thanks for the prompt review!
Bye,
Ale
More information about the armedbear-devel
mailing list