[armedbear-cvs] r13466 - trunk/abcl/src/org/armedbear/lisp
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Fri Aug 12 12:08:26 UTC 2011
Author: ehuelsmann
Date: Fri Aug 12 05:08:25 2011
New Revision: 13466
Log:
Reduce load time of nested functions and the number of class loader objects.
This commit groups all nested function objects resulting from a COMPILE call
into one class loader (instead of a class loader each). Additionally, nested
function objects aren't instantiated using reflection anymore, instead, the
'new' instruction is used, winning a factor 100 per local function.
Added:
trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java (contents, props changed)
Modified:
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/jvm.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Aug 12 05:00:39 2011 (r13465)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Aug 12 05:08:25 2011 (r13466)
@@ -706,6 +706,10 @@
autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false);
autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false);
+ autoload(PACKAGE_SYS, "make-memory-class-loader", "MemoryClassLoader", false);
+ autoload(PACKAGE_SYS, "put-memory-function", "MemoryClassLoader", false);
+ autoload(PACKAGE_SYS, "get-memory-function", "MemoryClassLoader", false);
+
autoload(Symbol.SET_CHAR, "StringFunctions");
autoload(Symbol.SET_SCHAR, "StringFunctions");
Added: trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Fri Aug 12 05:08:25 2011 (r13466)
@@ -0,0 +1,157 @@
+/*
+ * MemoryClassLoader.java
+ *
+ * Copyright (C) 2011 Erik Huelsmann
+ * Copyright (C) 2010 Alessio Stalla
+ * $Id$
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *
+ * As a special exception, the copyright holders of this library give you
+ * permission to link this library with independent modules to produce an
+ * executable, regardless of the license terms of these independent
+ * modules, and to copy and distribute the resulting executable under
+ * terms of your choice, provided that you also meet, for each linked
+ * independent module, the terms and conditions of the license of that
+ * module. An independent module is a module which is not derived from
+ * or based on this library. If you modify this library, you may extend
+ * this exception to your version of the library, but you are not
+ * obligated to do so. If you do not wish to do so, delete this
+ * exception statement from your version.
+ */
+
+package org.armedbear.lisp;
+
+import static org.armedbear.lisp.Lisp.*;
+
+import java.util.*;
+
+public class MemoryClassLoader extends JavaClassLoader {
+
+ private final HashMap<String, JavaObject> hashtable = new HashMap<String, JavaObject>(5, 0.81);
+ private final JavaObject boxedThis = new JavaObject(this);
+
+ public MemoryClassLoader() {
+ }
+
+ @Override
+ protected Class<?> loadClass(String name, boolean resolve)
+ throws ClassNotFoundException {
+ /* First we check if we should load the class ourselves,
+ * allowing the default handlers to kick in if we don't...
+ *
+ * This strategy eliminates ClassNotFound exceptions inside
+ * the inherited loadClass() eliminated ~80k exceptions during
+ * Maxima compilation. Generally, creation of an exception object
+ * is a pretty heavy operation, because it processes the call stack,
+ * which - in ABCL - is pretty deep, most of the time.
+ */
+ if (hashtable.containsKey(name)) {
+ String internalName = "org/armedbear/lisp/" + name;
+ Class<?> c = this.findLoadedClass(internalName);
+
+ if (c == null) {
+ c = findClass(name);
+ }
+ if (c != null) {
+ if (resolve) {
+ resolveClass(c);
+ }
+ return c;
+ }
+ }
+
+ // Fall through to our super's default handling
+ return super.loadClass(name, resolve);
+ }
+
+ @Override
+ protected Class<?> findClass(String name) throws ClassNotFoundException {
+ try {
+ byte[] b = getFunctionClassBytes(name);
+ return defineClass(name, b, 0, b.length);
+ } catch(Throwable e) { //TODO handle this better, readFunctionBytes uses Debug.assert() but should return null
+ e.printStackTrace();
+ if(e instanceof ControlTransfer) { throw (ControlTransfer) e; }
+ throw new ClassNotFoundException("Function class not found: " + name, e);
+ }
+ }
+
+ public byte[] getFunctionClassBytes(String name) {
+ return (byte[])hashtable.get(name).javaInstance();
+ }
+
+ public byte[] getFunctionClassBytes(Class<?> functionClass) {
+ return getFunctionClassBytes(functionClass.getName());
+ }
+
+ public byte[] getFunctionClassBytes(Function f) {
+ byte[] b = getFunctionClassBytes(f.getClass());
+ f.setClassBytes(b);
+ return b;
+ }
+
+ public LispObject loadFunction(String name) {
+ try {
+ Function f = (Function) loadClass(name).newInstance();
+ f.setClassBytes(getFunctionClassBytes(name));
+ return f;
+ } catch(Throwable e) {
+ if(e instanceof ControlTransfer) { throw (ControlTransfer) e; }
+ Debug.trace(e);
+ return error(new LispError("Compiled function can't be loaded: " + name + " from memory"));
+ }
+ }
+
+ private static final Primitive MAKE_MEMORY_CLASS_LOADER = new pf_make_memory_class_loader();
+ private static final class pf_make_memory_class_loader extends Primitive {
+ pf_make_memory_class_loader() {
+ super("make-memory-class-loader", PACKAGE_SYS, false);
+ }
+
+ @Override
+ public LispObject execute() {
+ return new MemoryClassLoader().boxedThis;
+ }
+ };
+
+ private static final Primitive PUT_MEMORY_FUNCTION = new pf_put_memory_function();
+ private static final class pf_put_memory_function extends Primitive {
+ pf_put_memory_function() {
+ super("put-memory-function", PACKAGE_SYS, false, "loader class-name class-bytes");
+ }
+
+ @Override
+ public LispObject execute(LispObject loader, LispObject className, LispObject classBytes) {
+ MemoryClassLoader l = (MemoryClassLoader) loader.javaInstance(MemoryClassLoader.class);
+ return (LispObject)l.hashtable.put(className.getStringValue(), (JavaObject)classBytes);
+ }
+ };
+
+ private static final Primitive GET_MEMORY_FUNCTION = new pf_get_memory_function();
+ private static final class pf_get_memory_function extends Primitive {
+ pf_get_memory_function() {
+ super("get-memory-function", PACKAGE_SYS, false, "loader class-name");
+ }
+
+ @Override
+ public LispObject execute(LispObject loader, LispObject name) {
+ MemoryClassLoader l = (MemoryClassLoader) loader.javaInstance(MemoryClassLoader.class);
+ return l.loadFunction(name.getStringValue());
+ }
+ };
+
+
+}
\ No newline at end of file
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 05:00:39 2011 (r13465)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 05:08:25 2011 (r13466)
@@ -49,6 +49,8 @@
pool-class pool-field pool-method pool-int
pool-float pool-long pool-double))
+(declaim (special *memory-class-loader*))
+
(defun pool-name (name)
(pool-add-utf8 *pool* name))
@@ -2206,10 +2208,7 @@
+lisp-object+))
(t
(dformat t "compile-local-function-call default case~%")
- (let* ((g (if *file-compilation*
- (declare-local-function local-function)
- (declare-object
- (local-function-function local-function)))))
+ (let* ((g (declare-local-function local-function)))
(emit-getstatic *this-class* g +lisp-object+)
; Stack: template-function
(when *closure-variables*
@@ -4063,9 +4062,12 @@
(compile-and-write-to-stream compiland stream)
(setf (local-function-class-file local-function)
(compiland-class-file compiland))
- (setf (local-function-function local-function)
- (load-compiled-function
- (sys::%get-output-stream-bytes stream))))))))
+ (let ((bytes (sys::%get-output-stream-bytes stream)))
+ (sys::put-memory-function *memory-class-loader*
+ (class-name-internal
+ (abcl-class-file-class-name
+ (compiland-class-file compiland)))
+ bytes)))))))
(defun emit-make-compiled-closure-for-labels
(local-function compiland declaration)
@@ -4096,11 +4098,16 @@
(compile-and-write-to-stream compiland stream)
(setf (local-function-class-file local-function)
(compiland-class-file compiland))
- (let ((g (declare-object
- (load-compiled-function
- (sys::%get-output-stream-bytes stream)))))
+ (let* ((bytes (sys::%get-output-stream-bytes stream))
+ (g (declare-local-function local-function)))
+ (sys::put-memory-function *memory-class-loader*
+ (class-name-internal
+ (abcl-class-file-class-name
+ (compiland-class-file compiland)))
+ bytes)
(emit-make-compiled-closure-for-labels
- local-function compiland g)))))))
+ local-function compiland g)
+ ))))))
(defknown p2-flet-node (t t t) t)
(defun p2-flet-node (block target representation)
@@ -4152,8 +4159,17 @@
(t
(with-open-stream (stream (sys::%make-byte-array-output-stream))
(compile-and-write-to-stream compiland stream)
- (emit-load-externalized-object (load-compiled-function
- (sys::%get-output-stream-bytes stream))))))
+ (let ((bytes (sys::%get-output-stream-bytes stream)))
+ (sys::put-memory-function *memory-class-loader*
+ (class-name-internal
+ (abcl-class-file-class-name
+ (compiland-class-file compiland)))
+ bytes)
+ (emit-getstatic *this-class*
+ (declare-local-function
+ (make-local-function
+ :class-file (compiland-class-file compiland)))
+ +lisp-object+)))))
(cond ((null *closure-variables*)) ; Nothing to do.
((compiland-closure-register *current-compiland*)
(duplicate-closure-array *current-compiland*)
@@ -4185,10 +4201,7 @@
(local-function-variable local-function))
'stack nil))
(t
- (let ((g (if *file-compilation*
- (declare-local-function local-function)
- (declare-object
- (local-function-function local-function)))))
+ (let ((g (declare-local-function local-function)))
(emit-getstatic *this-class* g +lisp-object+)
; Stack: template-function
@@ -4226,10 +4239,7 @@
(local-function-variable local-function))
'stack nil))
(t
- (let ((g (if *file-compilation*
- (declare-local-function local-function)
- (declare-object
- (local-function-function local-function)))))
+ (let ((g (declare-local-function local-function)))
(emit-getstatic *this-class*
g +lisp-object+))))) ; Stack: template-function
((and (member name *functions-defined-in-current-file* :test #'equal)
@@ -7380,7 +7390,10 @@
(defun compile-defun (name form environment filespec stream *declare-inline*)
"Compiles a lambda expression `form'. If `filespec' is NIL,
a random Java class name is generated, if it is non-NIL, it's used
-to derive a Java class name from."
+to derive a Java class name from.
+
+Returns the a abcl-class-file structure containing the description of the
+generated class."
(aver (eq (car form) 'LAMBDA))
(catch 'compile-defun-abort
(let* ((class-file (make-abcl-class-file :pathname filespec
@@ -7402,7 +7415,8 @@
(precompiler:precompile-form form t
environment)
:class-file class-file)
- stream))))
+ stream)
+ class-file)))
(defvar *catch-errors* t)
@@ -7496,15 +7510,22 @@
(defun %jvm-compile (name definition expr env)
;; This function is part of the call chain from COMPILE, but
;; not COMPILE-FILE
- (let* (compiled-function)
+ (let* (compiled-function
+ (*memory-class-loader* (sys::make-memory-class-loader)))
(with-compilation-unit ()
(with-saved-compiler-policy
(setf compiled-function
- (load-compiled-function
- (with-open-stream (s (sys::%make-byte-array-output-stream))
- (compile-defun name expr env nil s nil)
- (finish-output s)
- (sys::%get-output-stream-bytes s))))))
+ (with-open-stream (s (sys::%make-byte-array-output-stream))
+ (let* ((class-file (compile-defun name expr env nil s nil))
+ (bytes (progn
+ (finish-output s)
+ (sys::%get-output-stream-bytes s)))
+ (class-name (class-name-internal
+ (abcl-class-file-class-name class-file))))
+ (sys::put-memory-function *memory-class-loader*
+ class-name bytes)
+ (sys::get-memory-function *memory-class-loader*
+ class-name))))))
(when (and name (functionp compiled-function))
(sys::set-function-definition name compiled-function definition))
(or name compiled-function)))
Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 12 05:00:39 2011 (r13465)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 12 05:08:25 2011 (r13466)
@@ -380,7 +380,6 @@
definition
compiland
inline-expansion
- function ;; the function loaded through load-compiled-function
class-file ;; the class file structure for this function
variable ;; the variable which contains the loaded compiled function
;; or compiled closure
More information about the armedbear-cvs
mailing list