[armedbear-devel] [armedbear-cvs] r12742 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuels at gmail.com
Mon Jun 7 18:43:11 UTC 2010
Hi Alessio, Nice work!
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?
> + 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.)
> 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?
>
> (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).
Bye,
Erik.
More information about the armedbear-devel
mailing list