[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