[armedbear-devel] [armedbear-cvs] r12180 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
alessiostalla at gmail.com
Thu Oct 8 08:34:00 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...
As I said to Erik yesterday, I'd like to add a COMPILE-FROM-STREAM
primitive which works like COMPILE-FILE but saves no file at all, and
returns a function which, when invoked, behaves like (LOAD
"my-compiled-file.abcl") but again with no file involved. That is
harder to do than my previous patch and has more impact on the
codebase, but it would make compiling code from arbitrary sources a
no-brainer. (btw, I believe LOAD already handles arbitrary streams).
> As soon as I have some progress to report, I'll let you know.
That is much appreciated :)
Bye,
Alessio
> 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
>>>
>>
>
> _______________________________________________
> armedbear-devel mailing list
> armedbear-devel at common-lisp.net
> http://common-lisp.net/cgi-bin/mailman/listinfo/armedbear-devel
>
More information about the armedbear-devel
mailing list