[armedbear-devel] [armedbear-cvs] r12180 - trunk/abcl/src/org/armedbear/lisp

John Pallister john at synchromesh.com
Thu Oct 8 08:18:59 UTC 2009


w00t! Thanks for that Alessio and Erik. And now it looks like it
should be relatively straightforward to load compiled code from, say,
the GAE datastore and/or memcache...

As soon as I have some progress to report, I'll let you know.

Cheers,

John :^P

On Thu, Oct 8, 2009 at 8:20 AM, Erik Huelsmann <ehuels at gmail.com> wrote:
> John,
>
> The commit below removes temporary file use from the COMPILE function.
> This is the minimal requirement to get running on GAE. So, I hope that
> you'll be using ABCL as of this version in your testing. I'm eager to
> learn about your progress.
>
> If you run into issues, please don't hesitate, we definitely want to
> fix them. If at all possible I'm for doing that ASAP.
>
> Bye,
>
>
> Erik.
>
> On Wed, Oct 7, 2009 at 11:51 PM, Alessio Stalla <astalla at common-lisp.net> wrote:
>> Author: astalla
>> Date: Wed Oct  7 17:51:00 2009
>> New Revision: 12180
>>
>> Log:
>> Ticket #56: eliminated use of temporary files for COMPILE
>>
>>
>> Modified:
>>   trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java
>>   trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java
>>   trunk/abcl/src/org/armedbear/lisp/Lisp.java
>>   trunk/abcl/src/org/armedbear/lisp/Stream.java
>>   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
>>   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java      (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java      Wed Oct  7 17:51:00 2009
>> @@ -207,7 +207,7 @@
>>
>>   // ### load-compiled-function
>>   private static final Primitive LOAD_COMPILED_FUNCTION =
>> -      new Primitive("load-compiled-function", PACKAGE_SYS, true, "pathname")
>> +      new Primitive("load-compiled-function", PACKAGE_SYS, true, "source")
>>   {
>>     @Override
>>     public LispObject execute(LispObject arg) throws ConditionThrowable
>> @@ -219,6 +219,14 @@
>>         namestring = arg.getStringValue();
>>       if (namestring != null)
>>         return loadCompiledFunction(namestring);
>> +      if(arg instanceof JavaObject) {
>> +         try {
>> +             return loadCompiledFunction((byte[]) arg.javaInstance(byte[].class));
>> +         } catch(Throwable t) {
>> +             Debug.trace(t);
>> +             return error(new LispError("Unable to load " + arg.writeToString()));
>> +         }
>> +      }
>>       return error(new LispError("Unable to load " + arg.writeToString()));
>>     }
>>   };
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java      (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java      Wed Oct  7 17:51:00 2009
>> @@ -37,17 +37,7 @@
>>  import java.util.HashSet;
>>  import java.util.Set;
>>
>> -public class JavaClassLoader extends ClassLoader
>> -{
>> -    private static final boolean isSableVM;
>> -
>> -    static {
>> -        String vm = System.getProperty("java.vm.name");
>> -        if (vm != null && vm.equals("SableVM"))
>> -            isSableVM = true;
>> -        else
>> -            isSableVM = false;
>> -    }
>> +public class JavaClassLoader extends ClassLoader {
>>
>>     private static JavaClassLoader persistentInstance;
>>
>> @@ -79,6 +69,10 @@
>>         }
>>     }
>>
>> +    public Class<?> loadClassFromByteArray(byte[] classbytes) {
>> +       return loadClassFromByteArray(null, classbytes);
>> +    }
>> +
>>     public Class<?> loadClassFromByteArray(String className,
>>                                                 byte[] classbytes)
>>     {
>>
>> 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 Wed Oct  7 17:51:00 2009
>> @@ -1376,6 +1376,16 @@
>>                                 new Pathname(namestring)));
>>   }
>>
>> +    public static final LispObject makeCompiledFunctionFromClass(Class<?> c)
>> +       throws Exception {
>> +       if (c != null) {
>> +           LispObject obj = (LispObject)c.newInstance();
>> +           return obj;
>> +        } else {
>> +            return null;
>> +        }
>> +    }
>> +
>>   private static final LispObject loadCompiledFunction(InputStream in, int size)
>>   {
>>     try
>> @@ -1405,21 +1415,19 @@
>>   }
>>
>>     public static final LispObject loadCompiledFunction(byte[] bytes) throws Throwable {
>> -        Class<?> c = (new JavaClassLoader())
>> -            .loadClassFromByteArray(null, bytes, 0, bytes.length);
>> -        if (c != null) {
>> -            Constructor constructor = c.getConstructor((Class[])null);
>> -            LispObject obj = (LispObject)constructor
>> -                .newInstance((Object[])null);
>> -            if (obj instanceof Function) {
>> -              ((Function)obj).setClassBytes(bytes);
>> -            }
>> -            return obj;
>> -        } else {
>> -            return null;
>> -        }
>> +       return loadCompiledFunction(bytes, new JavaClassLoader());
>>     }
>>
>> +    public static final LispObject loadCompiledFunction(byte[] bytes, JavaClassLoader cl) throws Throwable {
>> +        Class<?> c = cl.loadClassFromByteArray(null, bytes, 0, bytes.length);
>> +       LispObject obj = makeCompiledFunctionFromClass(c);
>> +       if (obj instanceof Function) {
>> +           ((Function)obj).setClassBytes(bytes);
>> +       }
>> +       return obj;
>> +    }
>> +
>> +
>>   public static final LispObject makeCompiledClosure(LispObject template,
>>                                                      ClosureBinding[] context)
>>     throws ConditionThrowable
>>
>> Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java
>> ==============================================================================
>> --- trunk/abcl/src/org/armedbear/lisp/Stream.java       (original)
>> +++ trunk/abcl/src/org/armedbear/lisp/Stream.java       Wed Oct  7 17:51:00 2009
>> @@ -119,6 +119,14 @@
>>   {
>>   }
>>
>> +    public Stream(Reader r) {
>> +       initAsCharacterInputStream(r);
>> +    }
>> +
>> +    public Stream(Writer w) {
>> +       initAsCharacterOutputStream(w);
>> +    }
>> +
>>   public Stream(InputStream inputStream, LispObject elementType)
>>     {
>>       this(inputStream, elementType, keywordDefault);
>>
>> 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 Wed Oct  7 17:51:00 2009
>> @@ -146,11 +146,17 @@
>>                    (parse-body body)
>>                  (let* ((expr `(lambda ,lambda-list
>>                                  , at decls (block ,block-name , at body)))
>> -                        (classfile-name (next-classfile-name))
>> -                        (classfile (report-error
>> -                                    (jvm:compile-defun name expr nil
>> -                                                       classfile-name)))
>> +                        (classfile (next-classfile-name))
>> +                        (result (with-open-file
>> +                                   (f classfile
>> +                                      :direction :output
>> +                                      :element-type '(unsigned-byte 8)
>> +                                      :if-exists :supersede)
>> +                                 (report-error
>> +                                  (jvm:compile-defun name expr nil
>> +                                                     classfile f))))
>>                         (compiled-function (verify-load classfile)))
>> +                  (declare (ignore result))
>>                    (cond
>>                      (compiled-function
>>                       (setf form
>> @@ -205,10 +211,14 @@
>>            (let ((name (second form)))
>>              (eval form)
>>              (let* ((expr (function-lambda-expression (macro-function name)))
>> -                    (classfile-name (next-classfile-name))
>> -                    (classfile
>> -                     (ignore-errors
>> -                       (jvm:compile-defun nil expr nil classfile-name))))
>> +                    (classfile (next-classfile-name)))
>> +              (with-open-file
>> +                  (f classfile
>> +                     :direction :output
>> +                     :element-type '(unsigned-byte 8)
>> +                     :if-exists :supersede)
>> +                (ignore-errors
>> +                  (jvm:compile-defun nil expr nil classfile f)))
>>                (if (null (verify-load classfile))
>>                    ;; FIXME error or warning
>>                    (format *error-output* "; Unable to compile macro ~A~%" name)
>> @@ -342,10 +352,17 @@
>>                (eq (%car function-form) 'FUNCTION))
>>       (let ((lambda-expression (cadr function-form)))
>>         (jvm::with-saved-compiler-policy
>> -          (let* ((classfile-name (next-classfile-name))
>> -                 (classfile (report-error
>> -                             (jvm:compile-defun nil lambda-expression nil classfile-name)))
>> +          (let* ((classfile (next-classfile-name))
>> +                 (result
>> +                 (with-open-file
>> +                     (f classfile
>> +                        :direction :output
>> +                        :element-type '(unsigned-byte 8)
>> +                        :if-exists :supersede)
>> +                   (report-error
>> +                    (jvm:compile-defun nil lambda-expression nil classfile f))))
>>                  (compiled-function (verify-load classfile)))
>> +           (declare (ignore result))
>>             (cond (compiled-function
>>                    (setf (getf tail key)
>>                          `(load-compiled-function ,(file-namestring classfile))))
>> @@ -356,9 +373,16 @@
>>  (declaim (ftype (function (t) t) convert-toplevel-form))
>>  (defun convert-toplevel-form (form)
>>   (let* ((expr `(lambda () ,form))
>> -         (classfile-name (next-classfile-name))
>> -         (classfile (report-error (jvm:compile-defun nil expr nil classfile-name)))
>> +         (classfile (next-classfile-name))
>> +         (result
>> +         (with-open-file
>> +             (f classfile
>> +                :direction :output
>> +                :element-type '(unsigned-byte 8)
>> +                :if-exists :supersede)
>> +           (report-error (jvm:compile-defun nil expr nil classfile f))))
>>          (compiled-function (verify-load classfile)))
>> +    (declare (ignore result))
>>     (setf form
>>           (if compiled-function
>>               `(funcall (load-compiled-function ,(file-namestring classfile)))
>>
>> 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       Wed Oct  7 17:51:00 2009
>> @@ -4921,16 +4921,16 @@
>>     (emit-push-nil)
>>     (emit-move-from-stack target)))
>>
>> -(defun compile-and-write-to-file (class-file compiland)
>> +(defun compile-and-write-to-stream (class-file compiland stream)
>>   (with-class-file class-file
>>     (let ((*current-compiland* compiland))
>>       (with-saved-compiler-policy
>>          (p2-compiland compiland)
>> -       (write-class-file (compiland-class-file compiland))))))
>> +       (write-class-file (compiland-class-file compiland) stream)))))
>>
>> -(defun set-compiland-and-write-class-file (class-file compiland)
>> +(defun set-compiland-and-write-class (class-file compiland stream)
>>   (setf (compiland-class-file compiland) class-file)
>> -  (compile-and-write-to-file class-file compiland))
>> +  (compile-and-write-to-stream class-file compiland stream))
>>
>>
>>  (defmacro with-temp-class-file (pathname class-file lambda-list &body body)
>> @@ -4949,15 +4949,18 @@
>>            (let* ((pathname (funcall *pathnames-generator*))
>>                   (class-file (make-class-file :pathname pathname
>>                                                :lambda-list lambda-list)))
>> -            (set-compiland-and-write-class-file class-file compiland)
>> +            (with-open-class-file (f class-file)
>> +              (set-compiland-and-write-class class-file compiland f))
>>              (setf (local-function-class-file local-function) class-file)))
>>           (t
>> -          (with-temp-class-file
>> -              pathname class-file lambda-list
>> -              (set-compiland-and-write-class-file class-file compiland)
>> +          (let ((class-file (make-class-file
>> +                             :pathname (funcall *pathnames-generator*)
>> +                             :lambda-list lambda-list)))
>> +            (with-open-stream (stream (sys::%make-byte-array-output-stream))
>> +              (set-compiland-and-write-class class-file compiland stream)
>>               (setf (local-function-class-file local-function) class-file)
>>               (setf (local-function-function local-function)
>> -                     (load-compiled-function pathname)))))))
>> +                     (load-compiled-function (sys::%get-output-stream-bytes stream)))))))))
>>
>>  (defun emit-make-compiled-closure-for-labels
>>     (local-function compiland declaration)
>> @@ -4981,19 +4984,24 @@
>>            (let* ((pathname (funcall *pathnames-generator*))
>>                   (class-file (make-class-file :pathname pathname
>>                                                :lambda-list lambda-list)))
>> -            (set-compiland-and-write-class-file class-file compiland)
>> +            (with-open-class-file (f class-file)
>> +              (set-compiland-and-write-class class-file compiland f))
>>              (setf (local-function-class-file local-function) class-file)
>>              (let ((g (declare-local-function local-function)))
>>               (emit-make-compiled-closure-for-labels
>>                local-function compiland g))))
>>           (t
>> -          (with-temp-class-file
>> -              pathname class-file lambda-list
>> -              (set-compiland-and-write-class-file class-file compiland)
>> +          (let ((class-file (make-class-file
>> +                             :pathname (funcall *pathnames-generator*)
>> +                             :lambda-list lambda-list)))
>> +            (with-open-stream (stream (sys::%make-byte-array-output-stream))
>> +              (set-compiland-and-write-class class-file compiland stream)
>>               (setf (local-function-class-file local-function) class-file)
>> -              (let ((g (declare-object (load-compiled-function pathname))))
>> +              (let ((g (declare-object
>> +                        (load-compiled-function
>> +                         (sys::%get-output-stream-bytes stream)))))
>>                 (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)
>> @@ -5041,7 +5049,8 @@
>>                  (make-class-file :pathname (funcall *pathnames-generator*)
>>                                   :lambda-list lambda-list))
>>            (let ((class-file (compiland-class-file compiland)))
>> -            (compile-and-write-to-file class-file compiland)
>> +            (with-open-class-file (f class-file)
>> +              (compile-and-write-to-stream class-file compiland f))
>>              (emit 'getstatic *this-class*
>>                    (declare-local-function (make-local-function :class-file
>>                                                                 class-file))
>> @@ -5051,14 +5060,13 @@
>>              (setf (compiland-class-file compiland)
>>                    (make-class-file :pathname pathname
>>                                     :lambda-list lambda-list))
>> -             (unwind-protect
>> -                 (progn
>> -                  (compile-and-write-to-file (compiland-class-file compiland)
>> -                                              compiland)
>> -                   (emit 'getstatic *this-class*
>> -                         (declare-object (load-compiled-function pathname))
>> -                         +lisp-object+))
>> -               (delete-file pathname)))))
>> +            (with-open-stream (stream (sys::%make-byte-array-output-stream))
>> +              (compile-and-write-to-stream (compiland-class-file compiland)
>> +                                           compiland stream)
>> +              (emit 'getstatic *this-class*
>> +                    (declare-object (load-compiled-function
>> +                                     (sys::%get-output-stream-bytes stream)))
>> +                    +lisp-object+)))))
>>     (cond ((null *closure-variables*))  ; Nothing to do.
>>           ((compiland-closure-register *current-compiland*)
>>            (duplicate-closure-array *current-compiland*)
>> @@ -8030,7 +8038,14 @@
>>            (setf (compiland-arity compiland) arg-count)
>>            (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
>>
>> -(defun write-class-file (class-file)
>> +(defmacro with-open-class-file ((var class-file) &body body)
>> +  `(with-open-file (,var (class-file-pathname ,class-file)
>> +                        :direction :output
>> +                        :element-type '(unsigned-byte 8)
>> +                        :if-exists :supersede)
>> +     , at body))
>> +
>> +(defun write-class-file (class-file stream)
>>   (let* ((super (class-file-superclass class-file))
>>          (this-index (pool-class (class-file-class class-file)))
>>          (super-index (pool-class super))
>> @@ -8045,43 +8060,39 @@
>>     (when (and (boundp '*source-line-number*)
>>                (fixnump *source-line-number*))
>>       (pool-name "LineNumberTable")) ; Must be in pool!
>> -
>> -    ;; Write out the class file.
>> -    (with-open-file (stream (class-file-pathname class-file)
>> -                            :direction :output
>> -                            :element-type '(unsigned-byte 8)
>> -                            :if-exists :supersede)
>> -      (write-u4 #xCAFEBABE stream)
>> -      (write-u2 3 stream)
>> -      (write-u2 45 stream)
>> -      (write-constant-pool stream)
>> -      ;; access flags
>> -      (write-u2 #x21 stream)
>> -      (write-u2 this-index stream)
>> -      (write-u2 super-index stream)
>> -      ;; interfaces count
>> -      (write-u2 0 stream)
>> -      ;; fields count
>> -      (write-u2 (length *fields*) stream)
>> -      ;; fields
>> -      (dolist (field *fields*)
>> -        (write-field field stream))
>> -      ;; methods count
>> -      (write-u2 (1+ (length (class-file-methods class-file))) stream)
>> -      ;; methods
>> -      (dolist (method (class-file-methods class-file))
>> -        (write-method method stream))
>> -      (write-method constructor stream)
>> -      ;; attributes count
>> -      (cond (*file-compilation*
>> -             ;; attributes count
>> -             (write-u2 1 stream)
>> -             ;; attributes table
>> -             (write-source-file-attr (file-namestring *compile-file-truename*)
>> -                                     stream))
>> -            (t
>> -             ;; attributes count
>> -             (write-u2 0 stream))))))
>> +
>> +    (write-u4 #xCAFEBABE stream)
>> +    (write-u2 3 stream)
>> +    (write-u2 45 stream)
>> +    (write-constant-pool stream)
>> +    ;; access flags
>> +    (write-u2 #x21 stream)
>> +    (write-u2 this-index stream)
>> +    (write-u2 super-index stream)
>> +    ;; interfaces count
>> +    (write-u2 0 stream)
>> +    ;; fields count
>> +    (write-u2 (length *fields*) stream)
>> +    ;; fields
>> +    (dolist (field *fields*)
>> +      (write-field field stream))
>> +    ;; methods count
>> +    (write-u2 (1+ (length (class-file-methods class-file))) stream)
>> +    ;; methods
>> +    (dolist (method (class-file-methods class-file))
>> +      (write-method method stream))
>> +    (write-method constructor stream)
>> +    ;; attributes count
>> +    (cond (*file-compilation*
>> +          ;; attributes count
>> +          (write-u2 1 stream)
>> +          ;; attributes table
>> +          (write-source-file-attr (file-namestring *compile-file-truename*)
>> +                                  stream))
>> +         (t
>> +          ;; attributes count
>> +          (write-u2 0 stream)))
>> +    stream))
>>
>>  (defknown p2-compiland-process-type-declarations (list) t)
>>  (defun p2-compiland-process-type-declarations (body)
>> @@ -8359,7 +8370,7 @@
>>     (push execute-method (class-file-methods class-file)))
>>   t)
>>
>> -(defun compile-1 (compiland)
>> +(defun compile-1 (compiland stream)
>>   (let ((*all-variables* nil)
>>         (*closure-variables* nil)
>>         (*undefined-variables* nil)
>> @@ -8393,8 +8404,7 @@
>>       ;; Pass 2.
>>       (with-class-file (compiland-class-file compiland)
>>         (p2-compiland compiland)
>> -        (write-class-file (compiland-class-file compiland)))
>> -      (class-file-pathname (compiland-class-file compiland)))))
>> +        (write-class-file (compiland-class-file compiland) stream)))))
>>
>>  (defvar *compiler-error-bailout*)
>>
>> @@ -8402,7 +8412,7 @@
>>   `(lambda ,(cadr form)
>>      (error 'program-error :format-control "Execution of a form compiled with errors.")))
>>
>> -(defun compile-defun (name form environment filespec)
>> +(defun compile-defun (name form environment filespec stream)
>>   (aver (eq (car form) 'LAMBDA))
>>   (catch 'compile-defun-abort
>>     (let* ((class-file (make-class-file :pathname filespec
>> @@ -8415,13 +8425,15 @@
>>                                           :class-file
>>                                           (make-class-file :pathname ,filespec
>>                                                            :lambda-name ',name
>> -                                                           :lambda-list (cadr ',form))))))
>> +                                                           :lambda-list (cadr ',form)))
>> +                         ,stream)))
>>            (*compile-file-environment* environment))
>>         (compile-1 (make-compiland :name name
>>                                    :lambda-expression
>>                                    (precompiler:precompile-form form t
>>                                                                 environment)
>> -                                   :class-file class-file)))))
>> +                                   :class-file class-file)
>> +                  stream))))
>>
>>  (defvar *catch-errors* t)
>>
>> @@ -8517,11 +8529,22 @@
>>          (tempfile (make-temp-file)))
>>     (with-compilation-unit ()
>>       (with-saved-compiler-policy
>> -        (unwind-protect
>> -             (setf compiled-function
>> -                   (load-compiled-function
>> -                    (compile-defun name expr env tempfile))))
>> -        (delete-file tempfile)))
>> +         (setf compiled-function
>> +               (load-compiled-function
>> +                (if *file-compilation*
>> +                    (unwind-protect
>> +                         (progn
>> +                           (with-open-file (f tempfile
>> +                                              :direction :output
>> +                                              :element-type '(unsigned-byte 8)
>> +                                              :if-exists :supersede)
>> +                             (compile-defun name expr env tempfile f))
>> +                           tempfile)
>> +                      (delete-file tempfile))
>> +                    (with-open-stream (s (sys::%make-byte-array-output-stream))
>> +                      (compile-defun name expr env tempfile s)
>> +                      (finish-output s)
>> +                      (sys::%get-output-stream-bytes s)))))))
>>     (when (and name (functionp compiled-function))
>>       (sys::set-function-definition name compiled-function definition))
>>     (or name compiled-function)))
>>
>> _______________________________________________
>> armedbear-cvs mailing list
>> armedbear-cvs at common-lisp.net
>> http://common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs
>>
>




More information about the armedbear-devel mailing list