[armedbear-devel] [armedbear-cvs] r12180 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuels at gmail.com
Thu Oct 8 07:20:55 UTC 2009
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