Hi Alessio, Nice work! On Mon, Jun 7, 2010 at 8:30 PM, Alessio Stalla <astalla@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 ,@decls (block ,block-name ,@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 ,@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.