[armedbear-devel] [armedbear-cvs] r12742 - trunk/abcl/src/org/armedbear/lisp

Erik Huelsmann ehuels at gmail.com
Mon Jun 7 18:43:11 UTC 2010


Hi Alessio, Nice work!

On Mon, Jun 7, 2010 at 8:30 PM, Alessio Stalla <astalla at common-lisp.net> wrote:
> Author: astalla
> Date: Mon Jun  7 14:30:36 2010
> New Revision: 12742
>
> Log:
> less-reflection branch merged with trunk. verify-load temporarily disabled.
>
>
> Added:
>   trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java
>      - copied, changed from r12739, /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java
> Modified:
>   trunk/abcl/src/org/armedbear/lisp/Autoload.java
>   trunk/abcl/src/org/armedbear/lisp/Function.java
>   trunk/abcl/src/org/armedbear/lisp/Lisp.java
>   trunk/abcl/src/org/armedbear/lisp/Load.java
>   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
>   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
>   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
>   trunk/abcl/src/org/armedbear/lisp/disassemble.lisp
>   trunk/abcl/src/org/armedbear/lisp/gui.lisp
>   trunk/abcl/src/org/armedbear/lisp/load.lisp
>   trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
>   trunk/abcl/src/org/armedbear/lisp/proclaim.lisp
>
> Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
> ==============================================================================
> --- trunk/abcl/src/org/armedbear/lisp/Autoload.java     (original)
> +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java     Mon Jun  7 14:30:36 2010
> @@ -97,7 +97,7 @@
>             symbol.setSymbolFunction(new Autoload(symbol, null,
>                                                   "org.armedbear.lisp.".concat(className)));
>     }
> -
> +
>     public void load()
>     {
>         if (className != null) {
> @@ -684,6 +684,9 @@
>
>         autoload(Symbol.COPY_LIST, "copy_list");
>
> +       autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false);
> +       autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false);
> +
>         autoload(Symbol.SET_CHAR, "StringFunctions");
>         autoload(Symbol.SET_SCHAR, "StringFunctions");
>
>
> Copied: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (from r12739, /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java)
> ==============================================================================
> --- /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java  (original)
> +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java      Mon Jun  7 14:30:36 2010
> @@ -70,7 +70,15 @@
>
>     public byte[] getFunctionClassBytes(String name) {
>        Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls");
> -       return readFunctionBytes(pathname);
> +       final LispThread thread = LispThread.currentThread();
> +       SpecialBindingsMark mark = thread.markSpecialBindings();
> +       try {
> +           //thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, NIL);

Maybe a code comment why this needs commenting out? Or maybe it was an
unintended leftover?

> +           thread.bindSpecial(Symbol.LOAD_TRUENAME, NIL);
> +           return readFunctionBytes(pathname);
> +       } finally {
> +           thread.resetSpecialBindings(mark);
> +       }
>     }
>
>     public byte[] getFunctionClassBytes(Class<?> functionClass) {
>
> Modified: trunk/abcl/src/org/armedbear/lisp/Function.java
> ==============================================================================
> --- trunk/abcl/src/org/armedbear/lisp/Function.java     (original)
> +++ trunk/abcl/src/org/armedbear/lisp/Function.java     Mon Jun  7 14:30:36 2010
> @@ -175,23 +175,51 @@
>                             new JavaObject(bytes));
>     }
>
> +    public final LispObject getClassBytes() {
> +       LispObject o = getf(propertyList, Symbol.CLASS_BYTES, NIL);
> +       if(o != NIL) {
> +           return o;
> +       } else {
> +           ClassLoader c = getClass().getClassLoader();
> +           if(c instanceof FaslClassLoader) {
> +               return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this));
> +           } else {
> +               return NIL;
> +           }
> +       }
> +    }
> +
> +    public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes();
> +    public static final class pf_function_class_bytes extends Primitive {
> +       public pf_function_class_bytes() {
> +           super("function-class-bytes", PACKAGE_SYS, false, "function");
> +        }
> +        @Override
> +        public LispObject execute(LispObject arg) {
> +            if (arg instanceof Function) {
> +                return ((Function) arg).getClassBytes();
> +           }
> +            return type_error(arg, Symbol.FUNCTION);
> +        }
> +    }
> +
>     @Override
>     public LispObject execute()
>     {
> -        return error(new WrongNumberOfArgumentsException(this));
> +        return error(new WrongNumberOfArgumentsException(this, 0));
>     }
>
>     @Override
>     public LispObject execute(LispObject arg)
>     {
> -        return error(new WrongNumberOfArgumentsException(this));
> +        return error(new WrongNumberOfArgumentsException(this, 1));
>     }
>
>     @Override
>     public LispObject execute(LispObject first, LispObject second)
>
>     {
> -        return error(new WrongNumberOfArgumentsException(this));
> +        return error(new WrongNumberOfArgumentsException(this, 2));
>     }
>
>     @Override
> @@ -199,7 +227,7 @@
>                               LispObject third)
>
>     {
> -        return error(new WrongNumberOfArgumentsException(this));
> +        return error(new WrongNumberOfArgumentsException(this, 3));
>     }
>
>     @Override
> @@ -207,7 +235,7 @@
>                               LispObject third, LispObject fourth)
>
>     {
> -        return error(new WrongNumberOfArgumentsException(this));
> +        return error(new WrongNumberOfArgumentsException(this, 4));
>     }
>
>     @Override
> @@ -216,7 +244,7 @@
>                               LispObject fifth)
>
>     {
> -        return error(new WrongNumberOfArgumentsException(this));
> +        return error(new WrongNumberOfArgumentsException(this, 5));
>     }
>
>     @Override
> @@ -225,7 +253,7 @@
>                               LispObject fifth, LispObject sixth)
>
>     {
> -        return error(new WrongNumberOfArgumentsException(this));
> +        return error(new WrongNumberOfArgumentsException(this, 6));
>     }
>
>     @Override
> @@ -235,7 +263,7 @@
>                               LispObject seventh)
>
>     {
> -        return error(new WrongNumberOfArgumentsException(this));
> +        return error(new WrongNumberOfArgumentsException(this, 7));
>     }
>
>     @Override
> @@ -245,7 +273,7 @@
>                               LispObject seventh, LispObject eighth)
>
>     {
> -        return error(new WrongNumberOfArgumentsException(this));
> +        return error(new WrongNumberOfArgumentsException(this, 8));
>     }
>
>     @Override
>
> 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 Mon Jun  7 14:30:36 2010
> @@ -43,8 +43,6 @@
>  import java.net.URL;
>  import java.net.URLDecoder;
>  import java.util.Hashtable;
> -import java.util.zip.ZipEntry;
> -import java.util.zip.ZipFile;
>
>  public final class Lisp
>  {
> @@ -1266,6 +1264,7 @@
>               url = Lisp.class.getResource(name.getNamestring());
>               input = url.openStream();
>           } catch (IOException e) {
> +             System.err.println("Failed to read class bytes from boot class " + url);

I understand this from a debugging point of view, but maybe we want to
make sure ABCL doesn't crash hard if its unable to write to err, for
whatever reason? (Like being in a Swing app without console stream
bindings.)

>               error(new LispError("Failed to read class bytes from boot class " + url));
>           }
>       }
> @@ -2385,6 +2384,10 @@
>   public static final Symbol _LOAD_STREAM_ =
>     internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL);
>
> +    // ### *fasl-loader*
> +    public static final Symbol _FASL_LOADER_ =
> +       exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL);
> +
>   // ### *source*
>   // internal symbol
>   public static final Symbol _SOURCE_ =
> @@ -2758,4 +2761,16 @@
>     Symbol.DEBUG_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true));
>   }
>
> +  private static final SpecialOperator WITH_INLINE_CODE = new with_inline_code();
> +  private static class with_inline_code extends SpecialOperator {
> +    with_inline_code() {
> +      super("with-inline-code", PACKAGE_JVM, true, "(&optional target repr) &body body");
> +    }
> +    @Override
> +    public LispObject execute(LispObject args, Environment env)
> +    {
> +       return error(new SimpleError("This is a placeholder. It should only be called in compiled code, and tranformed by the compiler using special form handlers."));
> +    }
> +  }
> +
>  }
>
> Modified: trunk/abcl/src/org/armedbear/lisp/Load.java
> ==============================================================================
> --- trunk/abcl/src/org/armedbear/lisp/Load.java (original)
> +++ trunk/abcl/src/org/armedbear/lisp/Load.java Mon Jun  7 14:30:36 2010
> @@ -242,6 +242,7 @@
>         }
>     }
>
> +    private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*");
>     static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_");
>
>     public static final LispObject loadSystemFile(final String filename,
> @@ -268,7 +269,7 @@
>             String path = pathname.asEntryPath();
>             url = Lisp.class.getResource(path);
>             if (url == null || url.toString().endsWith("/")) {
> -                url = Lisp.class.getResource(path + ".abcl");
> +                url = Lisp.class.getResource(path.replace('-', '_') + ".abcl");
>                 if (url == null) {
>                     url = Lisp.class.getResource(path + ".lisp");
>                 }
> @@ -322,6 +323,7 @@
>             final LispThread thread = LispThread.currentThread();
>             final SpecialBindingsMark mark = thread.markSpecialBindings();
>             thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL);
> +           thread.bindSpecial(FASL_LOADER, NIL);
>             try {
>                 Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER);
>                 return loadFileFromStream(pathname, truename, stream,
> @@ -567,7 +569,7 @@
>                                          thread, Stream.currentReadtable);
>                 if (obj == EOF)
>                     break;
> -                result = eval(obj, env, thread);
> +               result = eval(obj, env, thread);
>                 if (print) {
>                     Stream out =
>                         checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread));
>
> 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 Mon Jun  7 14:30:36 2010
> @@ -40,17 +40,33 @@
>
>  (defvar *output-file-pathname*)
>
> +(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
> +  (sanitize-class-name (pathname-name output-file-pathname)))
> +
> +(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*))
> +  (%format nil "~A_0" (base-classname output-file-pathname)))
> +
>  (declaim (ftype (function (t) t) compute-classfile-name))
>  (defun compute-classfile-name (n &optional (output-file-pathname
>                                             *output-file-pathname*))
>   "Computes the name of the class file associated with number `n'."
>   (let ((name
> -         (%format nil "~A-~D"
> -                  (substitute #\_ #\.
> -                              (pathname-name output-file-pathname)) n)))
> +         (sanitize-class-name
> +         (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
>     (namestring (merge-pathnames (make-pathname :name name :type "cls")
>                                  output-file-pathname))))
>
> +(defun sanitize-class-name (name)
> +  (let ((name (copy-seq name)))
> +    (dotimes (i (length name))
> +      (declare (type fixnum i))
> +      (when (or (char= (char name i) #\-)
> +               (char= (char name i) #\.)
> +               (char= (char name i) #\Space))
> +        (setf (char name i) #\_)))
> +    name))
> +
> +
>  (declaim (ftype (function () t) next-classfile-name))
>  (defun next-classfile-name ()
>   (compute-classfile-name (incf *class-number*)))
> @@ -69,12 +85,14 @@
>
>  (declaim (ftype (function (t) t) verify-load))
>  (defun verify-load (classfile)
> -  (if (> *safety* 0)
> -    (and classfile
> +  #|(if (> *safety* 0)
> +      (and classfile
>          (let ((*load-truename* *output-file-pathname*))
>            (report-error
>             (load-compiled-function classfile))))
> -    t))
> +    t)|#
> +  (declare (ignore classfile))
> +  t)
>
>  (declaim (ftype (function (t) t) process-defconstant))
>  (defun process-defconstant (form)
> @@ -144,6 +162,7 @@
>                    (parse-body body)
>                  (let* ((expr `(lambda ,lambda-list
>                                  , at decls (block ,block-name , at body)))
> +                       (saved-class-number *class-number*)
>                         (classfile (next-classfile-name))
>                         (internal-compiler-errors nil)
>                         (result (with-open-file
> @@ -168,7 +187,8 @@
>                            compiled-function)
>                       (setf form
>                             `(fset ',name
> -                                   (proxy-preloaded-function ',name ,(file-namestring classfile))
> +                                  (sys::get-fasl-function *fasl-loader*
> +                                                          ,saved-class-number)
>                                    ,*source-position*
>                                    ',lambda-list
>                                    ,doc))
> @@ -225,6 +245,7 @@
>            (let ((name (second form)))
>              (eval form)
>              (let* ((expr (function-lambda-expression (macro-function name)))
> +                   (saved-class-number *class-number*)
>                     (classfile (next-classfile-name)))
>               (with-open-file
>                   (f classfile
> @@ -241,14 +262,10 @@
>                          (if (special-operator-p name)
>                              `(put ',name 'macroexpand-macro
>                                    (make-macro ',name
> -                                               (proxy-preloaded-function
> -                                                '(macro-function ,name)
> -                                                ,(file-namestring classfile))))
> +                                              (sys::get-fasl-function *fasl-loader* ,saved-class-number)))
>                              `(fset ',name
>                                     (make-macro ',name
> -                                                (proxy-preloaded-function
> -                                                 '(macro-function ,name)
> -                                                 ,(file-namestring classfile)))
> +                                               (sys::get-fasl-function *fasl-loader* ,saved-class-number))
>                                     ,*source-position*
>                                     ',(third form)))))))))
>           (DEFTYPE
> @@ -348,8 +365,12 @@
>   ;; to load the compiled functions. Note that this trickery
>   ;; was already used in verify-load before I used it,
>   ;; however, binding *load-truename* isn't fully compliant, I think.
> -  (let ((*load-truename* *output-file-pathname*))
> -    (when compile-time-too
> +  (when compile-time-too
> +    (let ((*load-truename* *output-file-pathname*)
> +         (*fasl-loader* (make-fasl-class-loader
> +                         *class-number*
> +                         (concatenate 'string "org.armedbear.lisp." (base-classname))
> +                         nil)))
>       (eval form))))
>
>  (declaim (ftype (function (t) t) convert-ensure-method))
> @@ -366,7 +387,8 @@
>                (eq (%car function-form) 'FUNCTION))
>       (let ((lambda-expression (cadr function-form)))
>         (jvm::with-saved-compiler-policy
> -          (let* ((classfile (next-classfile-name))
> +          (let* ((saved-class-number *class-number*)
> +                (classfile (next-classfile-name))
>                  (result
>                  (with-open-file
>                      (f classfile
> @@ -379,7 +401,8 @@
>            (declare (ignore result))
>             (cond (compiled-function
>                    (setf (getf tail key)
> -                         `(load-compiled-function ,(file-namestring classfile))))
> +                        `(sys::get-fasl-function *fasl-loader* ,saved-class-number)))
> +;;                         `(load-compiled-function ,(file-namestring classfile))))
>                   (t
>                    ;; FIXME This should be a warning or error of some sort...
>                    (format *error-output* "; Unable to compile method~%")))))))))
> @@ -412,6 +435,7 @@
>     (return-from convert-toplevel-form
>       (precompiler:precompile-form form nil *compile-file-environment*)))
>   (let* ((expr `(lambda () ,form))
> +        (saved-class-number *class-number*)
>          (classfile (next-classfile-name))
>          (result
>          (with-open-file
> @@ -425,7 +449,7 @@
>     (declare (ignore result))
>     (setf form
>           (if compiled-function
> -              `(funcall (load-compiled-function ,(file-namestring classfile)))
> +              `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number))
>               (precompiler:precompile-form form nil *compile-file-environment*)))))
>
>
> @@ -572,25 +596,22 @@
>               (write (list 'setq '*source* *compile-file-truename*)
>                      :stream out)
>               (%stream-terpri out)
> -              ;; Note: Beyond this point, you can't use DUMP-FORM,
> -              ;; because the list of uninterned symbols has been fixed now.
> -              (when *fasl-uninterned-symbols*
> -                (write (list 'setq '*fasl-uninterned-symbols*
> -                             (coerce (mapcar #'car
> -                                             (nreverse *fasl-uninterned-symbols*))
> -                                     'vector))
> -                       :stream out))
> -              (%stream-terpri out)
> -              ;; we work with a fixed variable name here to work around the
> -              ;; lack of availability of the circle reader in the fasl reader
> -              ;; but it's a toplevel form anyway
> -              (write `(dotimes (i ,*class-number*)
> -                        (function-preload
> -                         (%format nil "~A-~D.cls"
> -                                  ,(substitute #\_ #\. (pathname-name output-file))
> -                                  (1+ i))))
> -                     :stream out
> -                     :circle t)
> +             ;; Note: Beyond this point, you can't use DUMP-FORM,
> +             ;; because the list of uninterned symbols has been fixed now.
> +             (when *fasl-uninterned-symbols*
> +               (write (list 'setq '*fasl-uninterned-symbols*
> +                            (coerce (mapcar #'car
> +                                            (nreverse *fasl-uninterned-symbols*))
> +                                    'vector))
> +                      :stream out))
> +             (%stream-terpri out)
> +
> +             (when (> *class-number* 0)
> +               (generate-loader-function)
> +               (write (list 'setq '*fasl-loader*
> +                            `(sys::make-fasl-class-loader
> +                              ,*class-number*
> +                              ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out))
>               (%stream-terpri out))
>
>
> @@ -609,7 +630,11 @@
>                  (zipfile (namestring
>                            (merge-pathnames (make-pathname :type type)
>                                             output-file)))
> -                 (pathnames ()))
> +                 (pathnames nil)
> +                (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
> +                                                          output-file))))
> +           (when (probe-file fasl-loader)
> +             (push fasl-loader pathnames))
>             (dotimes (i *class-number*)
>               (let* ((pathname (compute-classfile-name (1+ i))))
>                 (when (probe-file pathname)
> @@ -632,6 +657,55 @@
>                   (namestring output-file) elapsed))))
>     (values (truename output-file) warnings-p failure-p)))
>
> +(defmacro ncase (expr min max &rest clauses)
> +  "A CASE where all test clauses are numbers ranging from a minimum to a maximum."
> +  ;;Expr is subject to multiple evaluation, but since we only use ncase for
> +  ;;fn-index below, let's ignore it.
> +  (let* ((half (floor (/ (- max min) 2)))
> +        (middle (+ min half)))
> +    (if (> (- max min) 10)
> +       `(if (< ,expr ,middle)
> +            (ncase ,expr ,min ,middle ,@(subseq clauses 0 half))
> +            (ncase ,expr ,middle ,max ,@(subseq clauses half)))
> +       `(case ,expr , at clauses))))
> +
> +(defun generate-loader-function ()
> +  (let* ((basename (base-classname))
> +        (expr `(lambda (fasl-loader fn-index)
> +                 (identity fasl-loader) ;;to avoid unused arg
> +                 (ncase fn-index 0 ,(1- *class-number*)
> +                   ,@(loop
> +                        :for i :from 1 :to *class-number*
> +                        :collect
> +                        (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)))
> +                          `(,(1- i)
> +                             (jvm::with-inline-code ()
> +                               (jvm::emit 'jvm::aload 1)
> +                               (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
> +                                                        nil jvm::+java-object+)
> +                               (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
> +                               (jvm::emit 'jvm::dup)
> +                               (jvm::emit-push-constant-int ,(1- i))
> +                               (jvm::emit 'jvm::new ,class)
> +                               (jvm::emit 'jvm::dup)
> +                               (jvm::emit-invokespecial-init ,class '())
> +                               (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
> +                                                        (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
> +                               (jvm::emit 'jvm::pop))
> +                             t))))))
> +        (classname (fasl-loader-classname))
> +        (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls")
> +                                                *output-file-pathname*))))
> +    (jvm::with-saved-compiler-policy
> +       (jvm::with-file-compilation
> +           (with-open-file
> +               (f classfile
> +                  :direction :output
> +                  :element-type '(unsigned-byte 8)
> +                  :if-exists :supersede)
> +             (jvm:compile-defun nil expr nil
> +                                classfile f nil))))))
> +
>  (defun compile-file-if-needed (input-file &rest allargs &key force-compile
>                                &allow-other-keys)
>   (setf input-file (truename input-file))
>
> Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
> ==============================================================================
> --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp       (original)
> +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp       Mon Jun  7 14:30:36 2010
> @@ -1298,7 +1298,7 @@
>                      (format t ";   inlining call to local function ~S~%" op)))
>                  (return-from p1-function-call
>                   (let ((*inline-declarations*
> -                         (remove op *inline-declarations* :key #'car)))
> +                         (remove op *inline-declarations* :key #'car :test #'equal)))
>                     (p1 expansion))))))
>
>            ;; FIXME
> @@ -1432,7 +1432,8 @@
>                   (TRULY-THE            p1-truly-the)
>                   (UNWIND-PROTECT       p1-unwind-protect)
>                   (THREADS:SYNCHRONIZED-ON
> -                                        p1-threads-synchronized-on)))
> +                                        p1-threads-synchronized-on)
> +                 (JVM::WITH-INLINE-CODE identity)))
>     (install-p1-handler (%car pair) (%cadr pair))))
>
>  (initialize-p1-handlers)
>
> 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       Mon Jun  7 14:30:36 2010
> @@ -198,6 +198,8 @@
>   (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
>           n)))
>
> +(defconstant +fasl-loader-class+
> +  "org/armedbear/lisp/FaslClassLoader")
>  (defconstant +java-string+ "Ljava/lang/String;")
>  (defconstant +java-object+ "Ljava/lang/Object;")
>  (defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
> @@ -2267,12 +2269,22 @@
>    local-function *declared-functions* ht g
>    (setf g (symbol-name (gensym "LFUN")))
>    (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function)))
> +         (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname)))
>          (*code* *static-code*))
>      ;; fixme *declare-inline*
> -     (declare-field g +lisp-object+ +field-access-default+)
> -     (emit 'ldc (pool-string (file-namestring pathname)))
> -     (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction"
> -                       (list +java-string+) +lisp-object+)
> +     (declare-field g +lisp-object+ +field-access-private+)
> +     (emit 'new class-name)
> +     (emit 'dup)
> +     (emit-invokespecial-init class-name '())
> +
> +     ;(emit 'ldc (pool-string (pathname-name pathname)))
> +     ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction"
> +     ;(list +java-string+) +lisp-object+)
> +
> +;     (emit 'ldc (pool-string (file-namestring pathname)))
> +
> +;     (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction"
> +;                      (list +java-string+) +lisp-object+)
>      (emit 'putstatic *this-class* g +lisp-object+)
>      (setf *static-code* *code*)
>      (setf (gethash local-function ht) g))))
> @@ -5094,7 +5106,8 @@
>                            (local-function-function local-function)))))
>                (emit 'getstatic *this-class*
>                      g +lisp-object+))))) ; Stack: template-function
> -         ((member name *functions-defined-in-current-file* :test #'equal)
> +         ((and (member name *functions-defined-in-current-file* :test #'equal)
> +              (not (notinline-p name)))
>           (emit 'getstatic *this-class*
>                 (declare-setf-function name) +lisp-object+)
>           (emit-move-from-stack target))
> @@ -7544,6 +7557,32 @@
>       ;; delay resolving the method to run-time; it's unavailable now
>       (compile-function-call form target representation))))
>
> +#|(defknown p2-java-jcall (t t t) t)
> +(define-inlined-function p2-java-jcall (form target representation)
> +  ((and (> *speed* *safety*)
> +       (< 1 (length form))
> +       (eq 'jmethod (car (cadr form)))
> +       (every #'stringp (cdr (cadr form)))))
> +  (let ((m (ignore-errors (eval (cadr form)))))
> +    (if m
> +       (let ((must-clear-values nil)
> +             (arg-types (raw-arg-types (jmethod-params m))))
> +         (declare (type boolean must-clear-values))
> +         (dolist (arg (cddr form))
> +           (compile-form arg 'stack nil)
> +           (unless must-clear-values
> +             (unless (single-valued-p arg)
> +               (setf must-clear-values t))))
> +         (when must-clear-values
> +           (emit-clear-values))
> +         (dotimes (i (jarray-length raw-arg-types))
> +           (push (jarray-ref raw-arg-types i) arg-types))
> +         (emit-invokevirtual (jclass-name (jmethod-declaring-class m))
> +                             (jmethod-name m)
> +                             (nreverse arg-types)
> +                             (jmethod-return-type m)))
> +      ;; delay resolving the method to run-time; it's unavailable now
> +      (compile-function-call form target representation))))|#

Maybe this can use a comment on why it's commented out? Is this not a
good idea? Does it depend on premises which are not (yet) met?
>
>  (defknown p2-char= (t t t) t)
>  (defun p2-char= (form target representation)
> @@ -8220,6 +8259,13 @@
>     (setf (method-handlers execute-method) (nreverse *handlers*)))
>   t)
>
> +(defun p2-with-inline-code (form target representation)
> +  ;;form = (with-inline-code (&optional target-var repr-var) ...body...)
> +  (destructuring-bind (&optional target-var repr-var) (cadr form)
> +    (eval `(let (,@(when target-var `((,target-var ,target)))
> +                ,@(when repr-var `((,repr-var ,representation))))
> +            ,@(cddr form)))))
> +
>  (defun compile-1 (compiland stream)
>   (let ((*all-variables* nil)
>         (*closure-variables* nil)
> @@ -8512,6 +8558,7 @@
>   (install-p2-handler 'java:jclass         'p2-java-jclass)
>   (install-p2-handler 'java:jconstructor   'p2-java-jconstructor)
>   (install-p2-handler 'java:jmethod        'p2-java-jmethod)
> +;  (install-p2-handler 'java:jcall          'p2-java-jcall)
>   (install-p2-handler 'char=               'p2-char=)
>   (install-p2-handler 'characterp          'p2-characterp)
>   (install-p2-handler 'coerce-to-function  'p2-coerce-to-function)
> @@ -8596,6 +8643,7 @@
>   (install-p2-handler 'vector-push-extend  'p2-vector-push-extend)
>   (install-p2-handler 'write-8-bits        'p2-write-8-bits)
>   (install-p2-handler 'zerop               'p2-zerop)
> +  (install-p2-handler 'with-inline-code    'p2-with-inline-code)
>   t)
>
>  (initialize-p2-handlers)
>
> Modified: trunk/abcl/src/org/armedbear/lisp/disassemble.lisp
> ==============================================================================
> --- trunk/abcl/src/org/armedbear/lisp/disassemble.lisp  (original)
> +++ trunk/abcl/src/org/armedbear/lisp/disassemble.lisp  Mon Jun  7 14:30:36 2010
> @@ -47,14 +47,15 @@
>     (when (functionp function)
>       (unless (compiled-function-p function)
>         (setf function (compile nil function)))
> -      (when (getf (function-plist function) 'class-bytes)
> -        (with-input-from-string
> -          (stream (disassemble-class-bytes (getf (function-plist function) 'class-bytes)))
> -          (loop
> -            (let ((line (read-line stream nil)))
> -              (unless line (return))
> -              (write-string "; ")
> -              (write-string line)
> -              (terpri))))
> -        (return-from disassemble)))
> -    (%format t "; Disassembly is not available.~%")))
> +      (let ((class-bytes (function-class-bytes function)))
> +       (when class-bytes
> +         (with-input-from-string
> +             (stream (disassemble-class-bytes class-bytes))
> +           (loop
> +              (let ((line (read-line stream nil)))
> +                (unless line (return))
> +                (write-string "; ")
> +                (write-string line)
> +                (terpri))))
> +         (return-from disassemble)))
> +      (%format t "; Disassembly is not available.~%"))))
>
> Modified: trunk/abcl/src/org/armedbear/lisp/gui.lisp
> ==============================================================================
> --- trunk/abcl/src/org/armedbear/lisp/gui.lisp  (original)
> +++ trunk/abcl/src/org/armedbear/lisp/gui.lisp  Mon Jun  7 14:30:36 2010
> @@ -1,5 +1,7 @@
>  (in-package :extensions)
>
> +(require :java)
> +
>  (defvar *gui-backend* :swing)
>
>  (defun init-gui ()
>
> Modified: trunk/abcl/src/org/armedbear/lisp/load.lisp
> ==============================================================================
> --- trunk/abcl/src/org/armedbear/lisp/load.lisp (original)
> +++ trunk/abcl/src/org/armedbear/lisp/load.lisp Mon Jun  7 14:30:36 2010
> @@ -38,10 +38,11 @@
>              (if-does-not-exist t)
>              (external-format :default))
>   (declare (ignore external-format)) ; FIXME
> -  (%load (if (streamp filespec)
> -             filespec
> -             (merge-pathnames (pathname filespec)))
> -         verbose print if-does-not-exist))
> +  (let (*fasl-loader*)
> +    (%load (if (streamp filespec)
> +              filespec
> +              (merge-pathnames (pathname filespec)))
> +          verbose print if-does-not-exist)))
>
>  (defun load-returning-last-result (filespec
>              &key
> @@ -50,7 +51,8 @@
>              (if-does-not-exist t)
>              (external-format :default))
>   (declare (ignore external-format)) ; FIXME
> -  (%load-returning-last-result (if (streamp filespec)
> -             filespec
> -             (merge-pathnames (pathname filespec)))
> -         verbose print if-does-not-exist))
> \ No newline at end of file
> +  (let (*fasl-loader*)
> +    (%load-returning-last-result (if (streamp filespec)
> +                                    filespec
> +                                    (merge-pathnames (pathname filespec)))
> +                                verbose print if-does-not-exist)))
> \ No newline at end of file
>
> Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
> ==============================================================================
> --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp  (original)
> +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp  Mon Jun  7 14:30:36 2010
> @@ -32,13 +32,10 @@
>  (in-package "SYSTEM")
>
>
> -(export '(*inline-declarations*
> -          process-optimization-declarations
> +(export '(process-optimization-declarations
>           inline-p notinline-p inline-expansion expand-inline
>           *defined-functions* *undefined-functions* note-name-defined))
>
> -(defvar *inline-declarations* nil)
> -
>  (declaim (ftype (function (t) t) process-optimization-declarations))
>  (defun process-optimization-declarations (forms)
>   (dolist (form forms)
> @@ -86,7 +83,7 @@
>  (declaim (ftype (function (t) t) inline-p))
>  (defun inline-p (name)
>   (declare (optimize speed))
> -  (let ((entry (assoc name *inline-declarations*)))
> +  (let ((entry (assoc name *inline-declarations* :test #'equal)))
>     (if entry
>         (eq (cdr entry) 'INLINE)
>         (and (symbolp name) (eq (get name '%inline) 'INLINE)))))
> @@ -94,7 +91,7 @@
>  (declaim (ftype (function (t) t) notinline-p))
>  (defun notinline-p (name)
>   (declare (optimize speed))
> -  (let ((entry (assoc name *inline-declarations*)))
> +  (let ((entry (assoc name *inline-declarations* :test #'equal)))
>     (if entry
>         (eq (cdr entry) 'NOTINLINE)
>         (and (symbolp name) (eq (get name '%inline) 'NOTINLINE)))))
> @@ -961,7 +958,8 @@
>                                                 (symbol-name symbol))
>                                   'precompiler))))
>     (unless (and handler (fboundp handler))
> -      (error "No handler for ~S." symbol))
> +      (error "No handler for ~S." (let ((*package* (find-package :keyword)))
> +                                   (format nil "~S" symbol))))
>     (setf (get symbol 'precompile-handler) handler)))
>
>  (defun install-handlers ()
> @@ -1024,7 +1022,9 @@
>                   (TRULY-THE            precompile-truly-the)
>
>                   (THREADS:SYNCHRONIZED-ON
> -                                        precompile-threads-synchronized-on)))
> +                                        precompile-threads-synchronized-on)
> +
> +                 (JVM::WITH-INLINE-CODE precompile-identity)))
>     (install-handler (first pair) (second pair))))
>
>  (install-handlers)
>
> Modified: trunk/abcl/src/org/armedbear/lisp/proclaim.lisp
> ==============================================================================
> --- trunk/abcl/src/org/armedbear/lisp/proclaim.lisp     (original)
> +++ trunk/abcl/src/org/armedbear/lisp/proclaim.lisp     Mon Jun  7 14:30:36 2010
> @@ -31,7 +31,7 @@
>
>  (in-package #:system)
>
> -(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type))
> +(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type *inline-declarations*))
>
>  (defmacro declaim (&rest decls)
>  `(eval-when (:compile-toplevel :load-toplevel :execute)
> @@ -43,6 +43,7 @@
>          :format-control "The symbol ~S cannot be both the name of a type and the name of a declaration."
>          :format-arguments (list name)))
>
> +(defvar *inline-declarations* nil)
>  (defvar *declaration-types* (make-hash-table :test 'eq))
>
>  ;; "A symbol cannot be both the name of a type and the name of a declaration.
> @@ -91,8 +92,9 @@
>      (apply 'proclaim-type (cdr declaration-specifier)))
>     ((INLINE NOTINLINE)
>      (dolist (name (cdr declaration-specifier))
> -       (when (symbolp name) ; FIXME Need to support non-symbol function names.
> -         (setf (get name '%inline) (car declaration-specifier)))))
> +       (if (symbolp name)
> +         (setf (get name '%inline) (car declaration-specifier))
> +        (push (cons name (car declaration-specifier)) *inline-declarations*))))
>     (DECLARATION
>      (dolist (name (cdr declaration-specifier))
>        (when (or (get name 'deftype-definition)

Thanks again! I hope this helps us getting a common base for things
happening in the FASL (such as constants and other stuff that we want
to create/instantiate only once; not every function class by itself).


Bye,

Erik.


More information about the armedbear-devel mailing list