[armedbear-devel] [armedbear-cvs] r12180 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuels at gmail.com
Thu Oct 15 20:48:03 UTC 2009
On Thu, Oct 8, 2009 at 10:18 AM, John Pallister <john at synchromesh.com> wrote:
> 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...
It turns out that even though we did not use the temp files created,
we were still creating them. I committed a new change just a few
minutes ago, which also assures we no longer try to create the temp
files for unique file generation.
> As soon as I have some progress to report, I'll let you know.
Hope this helps your progress!
Bye,
Erik.
> 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