Changeset 13466

Timestamp:

08/12/11 12:08:25 (12 years ago)

Author:

ehuelsmann

Message:

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.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (1 diff)
• MemoryClassLoader.java (added)
• compiler-pass2.lisp (modified) (10 diffs)
• jvm.lisp (modified) (1 diff)

trunk/abcl/src/org/armedbear/lisp/Autoload.java

@@ -707 +707 @@
   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");

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -49 +49 @@
                  pool-class pool-field pool-method pool-int
                  pool-float pool-long pool-double))
+
+(declaim (special *memory-class-loader*))
 
 (defun pool-name (name)
@@ -2207 +2209 @@
           (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
@@ -4064 +4063 @@
              (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
@@ -4097 +4099 @@
              (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)
@@ -4153 +4160 @@
          (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*)
@@ -4186 +4202 @@
                               '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
@@ -4227 +4240 @@
                               '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
@@ -7381 +7391 @@
   "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
@@ -7403 +7416 @@
                                                               environment)
                                  :class-file class-file)
-                 stream))))
+                 stream)
+      class-file)))
 
 (defvar *catch-errors* t)
@@ -7497 +7511 @@
   ;; 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))

trunk/abcl/src/org/armedbear/lisp/jvm.lisp

@@ -381 +381 @@
   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