[armedbear-cvs] r12180 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Wed Oct 7 21:51:03 UTC 2009
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)))
More information about the armedbear-cvs
mailing list