Changeset 12672

Timestamp:

05/12/10 22:52:33 (13 years ago)

Author:

astalla

Message:

FASL loader implemented. Has serious bugs (tests fail to compile), but can serve as a basis for further work.

Location:

branches/less-reflection/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (1 diff)
• FaslClassLoader.java (modified) (5 diffs)
• Function.java (modified) (9 diffs)
• Interpreter.java (modified) (1 diff)
• Lisp.java (modified) (1 diff)
• Load.java (modified) (3 diffs)
• compile-file.lisp (modified) (17 diffs)
• precompiler.lisp (modified) (1 diff)

branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java

@@ -98 +98 @@
                                                   "org.armedbear.lisp.".concat(className)));
     }
-
+    
     public void load()
     {

branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java

@@ -39 +39 @@
 
 public class FaslClassLoader extends JavaClassLoader {
+
+    private final LispObject[] functions;
+    private String baseName;
+    private LispObject loader; //The function used to load FASL functions by number
+    private final JavaObject boxedThis = new JavaObject(this);
     
+    public FaslClassLoader(int functionCount, String baseName, boolean useLoaderFunction) {
+  functions = new LispObject[functionCount];
+  this.baseName = baseName;
+  if(useLoaderFunction) {
+      try {
+    this.loader = (LispObject) loadClass(baseName + "_0").newInstance();
+      } catch(Exception e) {
+    //e.printStackTrace();
+    Debug.trace("useLoaderFunction = true but couldn't fully init FASL loader, will fall back to reflection!");
+      }
+  }
+    }
+
     protected Class<?> findClass(String name) throws ClassNotFoundException {
   try {
@@ -52 +70 @@
     }
 
-    //TODO have compiler generate subclass, TEST ONLY!!!
-    protected Map<String, LispObject> functions = new HashMap<String, LispObject>();
-
-    public LispObject loadFunction(String className) {
+    public LispObject loadFunction(int fnNumber) {
   try {
-      LispObject o = (LispObject) loadClass(className).newInstance();
-      functions.put(className, o);
+      //Function name is fnIndex + 1
+      LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance();
+      functions[fnNumber] = o;
       return o;
   } catch(Exception e) {
@@ -67 +83 @@
     }
     
-    public LispObject getFunction(final String className) {
-  LispObject o = functions.get(className);
+    public LispObject getFunction(int fnNumber) {
+  if(fnNumber >= functions.length) {
+      return error(new LispError("Compiled function not found: " + baseName + "_" + (fnNumber + 1) + " " + Symbol.LOAD_TRUENAME.symbolValue()));
+  }
+  LispObject o = functions[fnNumber];
   if(o == null) {
-      o = loadFunction(className);
+      if(loader != null) {
+    loader.execute(boxedThis, Fixnum.getInstance(fnNumber));
+    return functions[fnNumber];
+      } else { //Fallback to reflection
+    return loadFunction(fnNumber);
+      }
+  } else {
+      return o;
   }
-  return o;
     }
 
-    public static LispObject faslLoadFunction(String className) {
-  FaslClassLoader cl = (FaslClassLoader) LispThread.currentThread().safeSymbolValue(_FASL_LOADER_).javaInstance();
-  return cl.getFunction(className);
+    public LispObject putFunction(int fnNumber, LispObject fn) {
+  functions[fnNumber] = fn;
+  return fn;
     }
 
@@ -83 +108 @@
     private static final class pf_make_fasl_class_loader extends Primitive {
   pf_make_fasl_class_loader() {
-            super("make-fasl-class-loader", PACKAGE_SYS, false, "");
+            super("make-fasl-class-loader", PACKAGE_SYS, false, "function-count base-name");
         }
 
         @Override
-        public LispObject execute() {
-            return new JavaObject(new FaslClassLoader());
+        public LispObject execute(LispObject functionCount, LispObject baseName) {
+            return execute(functionCount, baseName, T);
+        }
+
+        @Override
+        public LispObject execute(LispObject functionCount, LispObject baseName, LispObject init) {
+            return new FaslClassLoader(functionCount.intValue(), baseName.getStringValue(), init != NIL).boxedThis;
         }
     };
@@ -95 +125 @@
     private static final class pf_get_fasl_function extends Primitive {
   pf_get_fasl_function() {
-            super("get-fasl-function", PACKAGE_SYS, false, "loader class-name");
+            super("get-fasl-function", PACKAGE_SYS, false, "loader function-number");
         }
 
         @Override
-        public LispObject execute(LispObject loader, LispObject className) {
+        public LispObject execute(LispObject loader, LispObject fnNumber) {
             FaslClassLoader l = (FaslClassLoader) loader.javaInstance(FaslClassLoader.class);
-      return l.getFunction("org.armedbear.lisp." + className.getStringValue());
+      return l.getFunction(fnNumber.intValue());
         }
     };

branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java

@@ -179 +179 @@
     public LispObject execute()
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 0));
     }
 
@@ -185 +185 @@
     public LispObject execute(LispObject arg)
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 1));
     }
 
@@ -192 +192 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 2));
     }
 
@@ -200 +200 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 3));
     }
 
@@ -208 +208 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 4));
     }
 
@@ -217 +217 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 5));
     }
 
@@ -226 +226 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 6));
     }
 
@@ -236 +236 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 7));
     }
 
@@ -246 +246 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 8));
     }
 

branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java

@@ -282 +282 @@
                             sb.append(separator);
                             System.err.print(sb.toString());
+          System.err.println("backtrace: ");
+          evaluate("(princ (sys::backtrace))");
                             System.exit(2);
                         }

branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java

@@ -1244 +1244 @@
               input = url.openStream();
           } catch (IOException e) {
+        System.err.println("Failed to read class bytes from boot class " + url);
               error(new LispError("Failed to read class bytes from boot class " + url));
           }

branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java

@@ -253 +253 @@
     }
 
+    private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*");
     static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_");
 
@@ -333 +334 @@
             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);
@@ -558 +560 @@
                 if (obj == EOF)
                     break;
-                result = eval(obj, env, thread);
+    result = eval(obj, env, thread);
                 if (print) {
                     Stream out =

branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp

@@ -41 +41 @@
 (defvar *output-file-pathname*)
 
+(defvar *function-packages* nil "An alist containing mappings (function-number . package). Every time an (IN-PACKAGE pkg) form is found at top-level, (*class-number* . pkg) is pushed onto this list.")
+
+(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
@@ -52 +60 @@
 
 (defun sanitize-class-name (name)
-  (dotimes (i (length name))
+  (let ((name (copy-seq name)))
+    (dotimes (i (length name))
       (declare (type fixnum i))
       (when (or (char= (char name i) #\-)
@@ -58 +67 @@
     (char= (char name i) #\Space))
         (setf (char name i) #\_)))
-  name)
+    name))
   
 
@@ -125 +134 @@
           ((IN-PACKAGE DEFPACKAGE)
            (note-toplevel-form form)
+     (if (eq operator 'in-package)
+         (push (cons (1+ *class-number*) (cadr form)) *function-packages*))
            (setf form (precompiler:precompile-form form nil *compile-file-environment*))
            (eval form)
@@ -157 +168 @@
                  (let* ((expr `(lambda ,lambda-list
                                  ,@decls (block ,block-name ,@body)))
+      (saved-class-number *class-number*)
                         (classfile (next-classfile-name))
                         (internal-compiler-errors nil)
@@ -182 +194 @@
                             `(fset ',name
            (sys::get-fasl-function *fasl-loader*
-                 ,(pathname-name classfile))
+                 ,saved-class-number)
 ;                                   (proxy-preloaded-function ',name ,(file-namestring classfile))
                                    ,*source-position*
@@ -240 +252 @@
              (eval form)
              (let* ((expr (function-lambda-expression (macro-function name)))
+        (saved-class-number *class-number*)
                     (classfile (next-classfile-name)))
          (with-open-file
@@ -259 +272 @@
                                                ; '(macro-function ,name)
                                                ; ,(file-namestring classfile))
-                 (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile))))
+                 (sys::get-fasl-function *fasl-loader* ,saved-class-number)))
                              `(fset ',name
                                     (make-macro ',name
@@ -265 +278 @@
                                                 ; '(macro-function ,name)
                                                 ; ,(file-namestring classfile))
-            (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)))
+            (sys::get-fasl-function *fasl-loader* ,saved-class-number))
                                     ,*source-position*
                                     ',(third form)))))))))
@@ -367 +380 @@
   (when compile-time-too
     (let ((*load-truename* *output-file-pathname*)
-    (*fasl-loader* (make-fasl-class-loader)))
+    (*fasl-loader* (make-fasl-class-loader
+        *class-number*
+        (concatenate 'string "org.armedbear.lisp." (base-classname))
+        nil)))
       (eval form))))
 
@@ -384 +400 @@
       (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
@@ -397 +414 @@
             (cond (compiled-function
                    (setf (getf tail key)
-       `(sys::get-fasl-function *fasl-loader* ,(pathname-name classfile))))
+       `(sys::get-fasl-function *fasl-loader* ,saved-class-number)))
 ;;                         `(load-compiled-function ,(file-namestring classfile))))
                   (t
@@ -431 +448 @@
       (precompiler:precompile-form form nil *compile-file-environment*)))
   (let* ((expr `(lambda () ,form))
+   (saved-class-number *class-number*)
          (classfile (next-classfile-name))
          (result
@@ -444 +462 @@
     (setf form
           (if compiled-function
-              `(funcall (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)));(load-compiled-function ,(file-namestring classfile)))
+              `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number))
               (precompiler:precompile-form form nil *compile-file-environment*)))))
 
@@ -531 +549 @@
              (*source* *compile-file-truename*)
              (*class-number* 0)
+       (*function-packages* nil)
              (namestring (namestring *compile-file-truename*))
              (start (get-internal-real-time))
@@ -593 +612 @@
               (%stream-terpri out)
 
-        ;;TODO FAKE TEST ONLY!!!
         (when (> *class-number* 0)
+    (let* ((basename (base-classname))
+           (expr `(lambda (fasl-loader fn-index)
+        (identity fasl-loader) ;;to avoid unused arg
+        ;;Ugly: should export & import JVM:: symbols
+        #|(let ((*package* *package*))
+        ,(let ((x (cdr (assoc 0 *function-packages*)))) ;;in-package before any function was defined
+          (when x
+            `(in-package ,(string x))))|#
+        (ecase fn-index
+          ,@(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::ldc (jvm::pool-string (symbol-name 'sys::*fasl-loader*)))
+          ;(jvm::emit 'jvm::ldc (jvm::pool-string (string :system)))
+          ;(jvm::emit-invokestatic jvm::+lisp-class+ "internInPackage"
+          ;(list jvm::+java-string+ jvm::+java-string+) jvm::+lisp-symbol+)
+          ;(jvm::emit-push-current-thread)
+          ;           (jvm::emit-invokevirtual jvm::+lisp-symbol-class+ "symbolValue"
+          ;                  (list jvm::+lisp-thread+) jvm::+lisp-object+)
+              (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)))))
     (write (list 'setq '*fasl-loader*
-           '(sys::make-fasl-class-loader)) :stream out)
+           `(sys::make-fasl-class-loader
+             ,*class-number*
+             ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)
     (%stream-terpri out))
 #|        (dump-form
@@ -634 +700 @@
                            (merge-pathnames (make-pathname :type type)
                                             output-file)))
-                 (pathnames ()))
+                 (pathnames (list (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
+                     output-file)))))
             (dotimes (i *class-number*)
               (let* ((pathname (compute-classfile-name (1+ i))))

branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp

@@ -959 +959 @@
                                   '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)))