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@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 ,@decls (block ,block-name ,@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)
- ,@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@common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs
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@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@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 ,@decls (block ,block-name ,@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)
- ,@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@common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs
On Thu, Oct 8, 2009 at 10:18 AM, John Pallister john@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@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@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 ,@decls (block ,block-name ,@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)
- ,@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@common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs
armedbear-devel mailing list armedbear-devel@common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/armedbear-devel
On Thu, Oct 8, 2009 at 10:18 AM, John Pallister john@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@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@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 ,@decls (block ,block-name ,@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)
- ,@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@common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs
armedbear-devel@common-lisp.net
-
Alessio Stalla -
Erik Huelsmann -
John Pallister