Changeset 12180


Ignore:
Timestamp:
10/07/09 21:51:00 (12 years ago)
Author:
astalla
Message:

Ticket #56: eliminated use of temporary files for COMPILE

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java

    r11889 r12180  
    208208  // ### load-compiled-function
    209209  private static final Primitive LOAD_COMPILED_FUNCTION =
    210       new Primitive("load-compiled-function", PACKAGE_SYS, true, "pathname")
     210      new Primitive("load-compiled-function", PACKAGE_SYS, true, "source")
    211211  {
    212212    @Override
     
    220220      if (namestring != null)
    221221        return loadCompiledFunction(namestring);
     222      if(arg instanceof JavaObject) {
     223    try {
     224        return loadCompiledFunction((byte[]) arg.javaInstance(byte[].class));
     225    } catch(Throwable t) {
     226        Debug.trace(t);
     227        return error(new LispError("Unable to load " + arg.writeToString()));
     228    }
     229      }
    222230      return error(new LispError("Unable to load " + arg.writeToString()));
    223231    }
  • trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java

    r12111 r12180  
    3838import java.util.Set;
    3939
    40 public class JavaClassLoader extends ClassLoader
    41 {
    42     private static final boolean isSableVM;
    43 
    44     static {
    45         String vm = System.getProperty("java.vm.name");
    46         if (vm != null && vm.equals("SableVM"))
    47             isSableVM = true;
    48         else
    49             isSableVM = false;
    50     }
     40public class JavaClassLoader extends ClassLoader {
    5141
    5242    private static JavaClassLoader persistentInstance;
     
    7868            packages.add(packageName);
    7969        }
     70    }
     71
     72    public Class<?> loadClassFromByteArray(byte[] classbytes) {
     73  return loadClassFromByteArray(null, classbytes);
    8074    }
    8175
  • trunk/abcl/src/org/armedbear/lisp/Lisp.java

    r12177 r12180  
    13771377  }
    13781378
     1379    public static final LispObject makeCompiledFunctionFromClass(Class<?> c)
     1380  throws Exception {
     1381  if (c != null) {
     1382      LispObject obj = (LispObject)c.newInstance();
     1383      return obj;
     1384        } else {
     1385            return null;
     1386        }
     1387    }
     1388
    13791389  private static final LispObject loadCompiledFunction(InputStream in, int size)
    13801390  {
     
    14061416
    14071417    public static final LispObject loadCompiledFunction(byte[] bytes) throws Throwable {
    1408         Class<?> c = (new JavaClassLoader())
    1409             .loadClassFromByteArray(null, bytes, 0, bytes.length);
    1410         if (c != null) {
    1411             Constructor constructor = c.getConstructor((Class[])null);
    1412             LispObject obj = (LispObject)constructor
    1413                 .newInstance((Object[])null);
    1414             if (obj instanceof Function) {
    1415               ((Function)obj).setClassBytes(bytes);
    1416             }
    1417             return obj;
    1418         } else {
    1419             return null;
    1420         }
     1418  return loadCompiledFunction(bytes, new JavaClassLoader());
    14211419    }
     1420
     1421    public static final LispObject loadCompiledFunction(byte[] bytes, JavaClassLoader cl) throws Throwable {
     1422        Class<?> c = cl.loadClassFromByteArray(null, bytes, 0, bytes.length);
     1423  LispObject obj = makeCompiledFunctionFromClass(c);
     1424  if (obj instanceof Function) {
     1425      ((Function)obj).setClassBytes(bytes);
     1426  }
     1427  return obj;
     1428    }
     1429
    14221430
    14231431  public static final LispObject makeCompiledClosure(LispObject template,
  • trunk/abcl/src/org/armedbear/lisp/Stream.java

    r12036 r12180  
    119119  {
    120120  }
     121
     122    public Stream(Reader r) {
     123  initAsCharacterInputStream(r);
     124    }
     125
     126    public Stream(Writer w) {
     127  initAsCharacterOutputStream(w);
     128    }
    121129
    122130  public Stream(InputStream inputStream, LispObject elementType)
  • trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

    r12090 r12180  
    147147                 (let* ((expr `(lambda ,lambda-list
    148148                                 ,@decls (block ,block-name ,@body)))
    149                         (classfile-name (next-classfile-name))
    150                         (classfile (report-error
    151                                     (jvm:compile-defun name expr nil
    152                                                        classfile-name)))
     149                        (classfile (next-classfile-name))
     150                        (result (with-open-file
     151            (f classfile
     152               :direction :output
     153               :element-type '(unsigned-byte 8)
     154               :if-exists :supersede)
     155          (report-error
     156           (jvm:compile-defun name expr nil
     157                  classfile f))))
    153158                        (compiled-function (verify-load classfile)))
     159       (declare (ignore result))
    154160                   (cond
    155161                     (compiled-function
     
    206212             (eval form)
    207213             (let* ((expr (function-lambda-expression (macro-function name)))
    208                     (classfile-name (next-classfile-name))
    209                     (classfile
    210                      (ignore-errors
    211                        (jvm:compile-defun nil expr nil classfile-name))))
     214                    (classfile (next-classfile-name)))
     215         (with-open-file
     216       (f classfile
     217          :direction :output
     218          :element-type '(unsigned-byte 8)
     219          :if-exists :supersede)
     220     (ignore-errors
     221       (jvm:compile-defun nil expr nil classfile f)))
    212222               (if (null (verify-load classfile))
    213223                   ;; FIXME error or warning
     
    343353      (let ((lambda-expression (cadr function-form)))
    344354        (jvm::with-saved-compiler-policy
    345           (let* ((classfile-name (next-classfile-name))
    346                  (classfile (report-error
    347                              (jvm:compile-defun nil lambda-expression nil classfile-name)))
     355          (let* ((classfile (next-classfile-name))
     356                 (result
     357      (with-open-file
     358          (f classfile
     359       :direction :output
     360       :element-type '(unsigned-byte 8)
     361       :if-exists :supersede)
     362        (report-error
     363         (jvm:compile-defun nil lambda-expression nil classfile f))))
    348364                 (compiled-function (verify-load classfile)))
     365      (declare (ignore result))
    349366            (cond (compiled-function
    350367                   (setf (getf tail key)
     
    357374(defun convert-toplevel-form (form)
    358375  (let* ((expr `(lambda () ,form))
    359          (classfile-name (next-classfile-name))
    360          (classfile (report-error (jvm:compile-defun nil expr nil classfile-name)))
     376         (classfile (next-classfile-name))
     377         (result
     378    (with-open-file
     379        (f classfile
     380     :direction :output
     381     :element-type '(unsigned-byte 8)
     382     :if-exists :supersede)
     383      (report-error (jvm:compile-defun nil expr nil classfile f))))
    361384         (compiled-function (verify-load classfile)))
     385    (declare (ignore result))
    362386    (setf form
    363387          (if compiled-function
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12175 r12180  
    49224922    (emit-move-from-stack target)))
    49234923
    4924 (defun compile-and-write-to-file (class-file compiland)
     4924(defun compile-and-write-to-stream (class-file compiland stream)
    49254925  (with-class-file class-file
    49264926    (let ((*current-compiland* compiland))
    49274927      (with-saved-compiler-policy
    49284928    (p2-compiland compiland)
    4929   (write-class-file (compiland-class-file compiland))))))
    4930 
    4931 (defun set-compiland-and-write-class-file (class-file compiland)
     4929  (write-class-file (compiland-class-file compiland) stream)))))
     4930
     4931(defun set-compiland-and-write-class (class-file compiland stream)
    49324932  (setf (compiland-class-file compiland) class-file)
    4933   (compile-and-write-to-file class-file compiland))
     4933  (compile-and-write-to-stream class-file compiland stream))
    49344934
    49354935
     
    49504950                  (class-file (make-class-file :pathname pathname
    49514951                                               :lambda-list lambda-list)))
    4952        (set-compiland-and-write-class-file class-file compiland)
     4952       (with-open-class-file (f class-file)
     4953         (set-compiland-and-write-class class-file compiland f))
    49534954             (setf (local-function-class-file local-function) class-file)))
    49544955          (t
    4955      (with-temp-class-file
    4956          pathname class-file lambda-list
    4957          (set-compiland-and-write-class-file class-file compiland)
     4956     (let ((class-file (make-class-file
     4957            :pathname (funcall *pathnames-generator*)
     4958            :lambda-list lambda-list)))
     4959       (with-open-stream (stream (sys::%make-byte-array-output-stream))
     4960         (set-compiland-and-write-class class-file compiland stream)
    49584961         (setf (local-function-class-file local-function) class-file)
    49594962         (setf (local-function-function local-function)
    4960                      (load-compiled-function pathname)))))))
     4963                     (load-compiled-function (sys::%get-output-stream-bytes stream)))))))))
    49614964
    49624965(defun emit-make-compiled-closure-for-labels
     
    49824985                  (class-file (make-class-file :pathname pathname
    49834986                                               :lambda-list lambda-list)))
    4984        (set-compiland-and-write-class-file class-file compiland)
     4987       (with-open-class-file (f class-file)
     4988         (set-compiland-and-write-class class-file compiland f))
    49854989             (setf (local-function-class-file local-function) class-file)
    49864990             (let ((g (declare-local-function local-function)))
     
    49884992    local-function compiland g))))
    49894993          (t
    4990      (with-temp-class-file
    4991          pathname class-file lambda-list
    4992          (set-compiland-and-write-class-file class-file compiland)
     4994     (let ((class-file (make-class-file
     4995            :pathname (funcall *pathnames-generator*)
     4996            :lambda-list lambda-list)))
     4997       (with-open-stream (stream (sys::%make-byte-array-output-stream))
     4998         (set-compiland-and-write-class class-file compiland stream)
    49934999         (setf (local-function-class-file local-function) class-file)
    4994          (let ((g (declare-object (load-compiled-function pathname))))
     5000         (let ((g (declare-object
     5001       (load-compiled-function
     5002        (sys::%get-output-stream-bytes stream)))))
    49955003     (emit-make-compiled-closure-for-labels
    4996       local-function compiland g)))))))
     5004      local-function compiland g))))))))
    49975005
    49985006(defknown p2-flet-node (t t t) t)
     
    50425050                                  :lambda-list lambda-list))
    50435051           (let ((class-file (compiland-class-file compiland)))
    5044        (compile-and-write-to-file class-file compiland)
     5052       (with-open-class-file (f class-file)
     5053         (compile-and-write-to-stream class-file compiland f))
    50455054             (emit 'getstatic *this-class*
    50465055                   (declare-local-function (make-local-function :class-file
     
    50525061                   (make-class-file :pathname pathname
    50535062                                    :lambda-list lambda-list))
    5054              (unwind-protect
    5055                  (progn
    5056        (compile-and-write-to-file (compiland-class-file compiland)
    5057                                               compiland)
    5058                    (emit 'getstatic *this-class*
    5059                          (declare-object (load-compiled-function pathname))
    5060                          +lisp-object+))
    5061                (delete-file pathname)))))
     5063       (with-open-stream (stream (sys::%make-byte-array-output-stream))
     5064         (compile-and-write-to-stream (compiland-class-file compiland)
     5065              compiland stream)
     5066         (emit 'getstatic *this-class*
     5067         (declare-object (load-compiled-function
     5068              (sys::%get-output-stream-bytes stream)))
     5069         +lisp-object+)))))
    50625070    (cond ((null *closure-variables*))  ; Nothing to do.
    50635071          ((compiland-closure-register *current-compiland*)
     
    80318039           (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
    80328040
    8033 (defun write-class-file (class-file)
     8041(defmacro with-open-class-file ((var class-file) &body body)
     8042  `(with-open-file (,var (class-file-pathname ,class-file)
     8043       :direction :output
     8044       :element-type '(unsigned-byte 8)
     8045       :if-exists :supersede)
     8046     ,@body))
     8047
     8048(defun write-class-file (class-file stream)
    80348049  (let* ((super (class-file-superclass class-file))
    80358050         (this-index (pool-class (class-file-class class-file)))
     
    80468061               (fixnump *source-line-number*))
    80478062      (pool-name "LineNumberTable")) ; Must be in pool!
    8048 
    8049     ;; Write out the class file.
    8050     (with-open-file (stream (class-file-pathname class-file)
    8051                             :direction :output
    8052                             :element-type '(unsigned-byte 8)
    8053                             :if-exists :supersede)
    8054       (write-u4 #xCAFEBABE stream)
    8055       (write-u2 3 stream)
    8056       (write-u2 45 stream)
    8057       (write-constant-pool stream)
    8058       ;; access flags
    8059       (write-u2 #x21 stream)
    8060       (write-u2 this-index stream)
    8061       (write-u2 super-index stream)
    8062       ;; interfaces count
    8063       (write-u2 0 stream)
    8064       ;; fields count
    8065       (write-u2 (length *fields*) stream)
    8066       ;; fields
    8067       (dolist (field *fields*)
    8068         (write-field field stream))
    8069       ;; methods count
    8070       (write-u2 (1+ (length (class-file-methods class-file))) stream)
    8071       ;; methods
    8072       (dolist (method (class-file-methods class-file))
    8073         (write-method method stream))
    8074       (write-method constructor stream)
    8075       ;; attributes count
    8076       (cond (*file-compilation*
    8077              ;; attributes count
    8078              (write-u2 1 stream)
    8079              ;; attributes table
    8080              (write-source-file-attr (file-namestring *compile-file-truename*)
    8081                                      stream))
    8082             (t
    8083              ;; attributes count
    8084              (write-u2 0 stream))))))
     8063   
     8064    (write-u4 #xCAFEBABE stream)
     8065    (write-u2 3 stream)
     8066    (write-u2 45 stream)
     8067    (write-constant-pool stream)
     8068    ;; access flags
     8069    (write-u2 #x21 stream)
     8070    (write-u2 this-index stream)
     8071    (write-u2 super-index stream)
     8072    ;; interfaces count
     8073    (write-u2 0 stream)
     8074    ;; fields count
     8075    (write-u2 (length *fields*) stream)
     8076    ;; fields
     8077    (dolist (field *fields*)
     8078      (write-field field stream))
     8079    ;; methods count
     8080    (write-u2 (1+ (length (class-file-methods class-file))) stream)
     8081    ;; methods
     8082    (dolist (method (class-file-methods class-file))
     8083      (write-method method stream))
     8084    (write-method constructor stream)
     8085    ;; attributes count
     8086    (cond (*file-compilation*
     8087     ;; attributes count
     8088     (write-u2 1 stream)
     8089     ;; attributes table
     8090     (write-source-file-attr (file-namestring *compile-file-truename*)
     8091           stream))
     8092    (t
     8093     ;; attributes count
     8094     (write-u2 0 stream)))
     8095    stream))
    80858096
    80868097(defknown p2-compiland-process-type-declarations (list) t)
     
    83608371  t)
    83618372
    8362 (defun compile-1 (compiland)
     8373(defun compile-1 (compiland stream)
    83638374  (let ((*all-variables* nil)
    83648375        (*closure-variables* nil)
     
    83948405      (with-class-file (compiland-class-file compiland)
    83958406        (p2-compiland compiland)
    8396         (write-class-file (compiland-class-file compiland)))
    8397       (class-file-pathname (compiland-class-file compiland)))))
     8407        (write-class-file (compiland-class-file compiland) stream)))))
    83988408
    83998409(defvar *compiler-error-bailout*)
     
    84038413     (error 'program-error :format-control "Execution of a form compiled with errors.")))
    84048414
    8405 (defun compile-defun (name form environment filespec)
     8415(defun compile-defun (name form environment filespec stream)
    84068416  (aver (eq (car form) 'LAMBDA))
    84078417  (catch 'compile-defun-abort
     
    84168426                                          (make-class-file :pathname ,filespec
    84178427                                                           :lambda-name ',name
    8418                                                            :lambda-list (cadr ',form))))))
     8428                                                           :lambda-list (cadr ',form)))
     8429        ,stream)))
    84198430           (*compile-file-environment* environment))
    84208431        (compile-1 (make-compiland :name name
     
    84228433                                   (precompiler:precompile-form form t
    84238434                                                                environment)
    8424                                    :class-file class-file)))))
     8435                                   :class-file class-file)
     8436       stream))))
    84258437
    84268438(defvar *catch-errors* t)
     
    85188530    (with-compilation-unit ()
    85198531      (with-saved-compiler-policy
    8520         (unwind-protect
    8521              (setf compiled-function
    8522                    (load-compiled-function
    8523                     (compile-defun name expr env tempfile))))
    8524         (delete-file tempfile)))
     8532    (setf compiled-function
     8533    (load-compiled-function   
     8534     (if *file-compilation*
     8535         (unwind-protect
     8536        (progn
     8537          (with-open-file (f tempfile
     8538                 :direction :output
     8539                 :element-type '(unsigned-byte 8)
     8540                 :if-exists :supersede)
     8541            (compile-defun name expr env tempfile f))
     8542          tempfile)
     8543           (delete-file tempfile))
     8544         (with-open-stream (s (sys::%make-byte-array-output-stream))
     8545           (compile-defun name expr env tempfile s)
     8546           (finish-output s)
     8547           (sys::%get-output-stream-bytes s)))))))
    85258548    (when (and name (functionp compiled-function))
    85268549      (sys::set-function-definition name compiled-function definition))
Note: See TracChangeset for help on using the changeset viewer.