Changeset 12630

Timestamp:

04/23/10 21:23:02 (13 years ago)

Author:

astalla

Message:

First rough attempt at a fasl classloader to load local functions using new.
Top-level functions are loaded through the same classloader but still using
reflection.

Location:

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

Files:

• Autoload.java (modified) (1 diff)
• Lisp.java (modified) (1 diff)
• Load.java (modified) (1 diff)
• compile-file.lisp (modified) (9 diffs)
• compiler-pass1.lisp (modified) (1 diff)
• compiler-pass2.lisp (modified) (6 diffs)
• gui.lisp (modified) (1 diff)
• java.lisp (modified) (1 diff)
• load.lisp (modified) (2 diffs)
• precompiler.lisp (modified) (3 diffs)
• proclaim.lisp (modified) (3 diffs)
• subtypep.lisp (modified) (1 diff)

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

@@ -684 +684 @@
         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");

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

@@ -2363 +2363 @@
     internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL);
 
+    // ### *fasl-loader*
+    public static final Symbol _FASL_LOADER_ =
+  exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL);
+
   // ### *source*
   // internal symbol

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

@@ -279 +279 @@
             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");

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

@@ -46 +46 @@
   "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)
+  (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))
@@ -70 +79 @@
 (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))
@@ -169 +181 @@
                       (setf form
                             `(fset ',name
-                                   (proxy-preloaded-function ',name ,(file-namestring classfile))
+           (sys::get-fasl-function *fasl-loader*
+                 ,(pathname-name classfile))
+;                                   (proxy-preloaded-function ',name ,(file-namestring classfile))
                                    ,*source-position*
                                    ',lambda-list
@@ -242 +256 @@
                              `(put ',name 'macroexpand-macro
                                    (make-macro ',name
-                                               (proxy-preloaded-function
-                                                '(macro-function ,name)
-                                                ,(file-namestring classfile))))
+                                               ;(proxy-preloaded-function
+                                               ; '(macro-function ,name)
+                                               ; ,(file-namestring classfile))
+                 (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile))))
                              `(fset ',name
                                     (make-macro ',name
-                                                (proxy-preloaded-function
-                                                 '(macro-function ,name)
-                                                 ,(file-namestring classfile)))
+                                                ;(proxy-preloaded-function
+                                                ; '(macro-function ,name)
+                                                ; ,(file-namestring classfile))
+            (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)))
                                     ,*source-position*
                                     ',(third form)))))))))
@@ -349 +365 @@
   ;; 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)))
       (eval form))))
 
@@ -380 +397 @@
             (cond (compiled-function
                    (setf (getf tail key)
-                         `(load-compiled-function ,(file-namestring classfile))))
+       `(sys::get-fasl-function *fasl-loader* ,(pathname-name classfile))))
+;;                         `(load-compiled-function ,(file-namestring classfile))))
                   (t
                    ;; FIXME This should be a warning or error of some sort...
@@ -426 +444 @@
     (setf form
           (if compiled-function
-              `(funcall (load-compiled-function ,(file-namestring classfile)))
+              `(funcall (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)));(load-compiled-function ,(file-namestring classfile)))
               (precompiler:precompile-form form nil *compile-file-environment*)))))
 
@@ -566 +584 @@
             (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
             (%stream-terpri out)
-            (let ((*package* (find-package '#:cl))
-                  (count-sym (gensym)))
+            (let ((*package* (find-package '#:cl)))
+                  ;(count-sym (gensym)))
               (write (list 'init-fasl :version *fasl-version*)
                      :stream out)
@@ -574 +592 @@
                      :stream out)
               (%stream-terpri out)
-              (dump-form `(dotimes (,count-sym ,*class-number*)
+
+        ;;TODO FAKE TEST ONLY!!!
+        (when (> *class-number* 0)
+    (write (list 'setq '*fasl-loader*
+           '(sys::make-fasl-class-loader)) :stream out)
+    (%stream-terpri out))
+#|        (dump-form
+         `(dotimes (,count-sym ,*class-number*)
+      (java:jcall "loadFunction" *fasl-loader*
+            (%format nil "~A_~D"
+               ,(sanitize-class-name
+           (pathname-name output-file))
+               (1+ ,count-sym))))
+         out)|#
+
+        ;;END TODO
+
+#|              (dump-form `(dotimes (,count-sym ,*class-number*)
                             (function-preload
-                             (%format nil "~A-~D.cls" 
-                                      ,(substitute #\_ #\. (pathname-name output-file))
-                                      (1+ ,count-sym)))) out)
+                             (%format nil "~A_~D.cls"
+                                      ,(sanitize-class-name
+          (pathname-name output-file))
+                                      (1+ ,count-sym))))
+       out)|#
               (%stream-terpri out))
 

branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -1299 +1299 @@
                  (return-from p1-function-call
        (let ((*inline-declarations*
-        (remove op *inline-declarations* :key #'car)))
+        (remove op *inline-declarations* :key #'car :test #'equal)))
          (p1 expansion))))))
 

branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -199 +199 @@
           n)))
 
+(defconstant +fasl-loader-class+
+  "org/armedbear/lisp/FaslClassLoader")
 (defconstant +java-string+ "Ljava/lang/String;")
 (defconstant +java-object+ "Ljava/lang/Object;")
@@ -2175 +2177 @@
    (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+)
+     (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*)
@@ -2331 +2343 @@
   (let ((g (symbol-name (gensym "INSTANCE")))
         saved-code)
+    (sys::%format t "OBJ = ~A ~S~%" (type-of obj) obj)
     (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
            (*code* (if *declare-inline* *code* *static-code*)))
@@ -5316 +5329 @@
                (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+)
@@ -7892 +7906 @@
       (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))))|#
 
 (defknown p2-char= (t t t) t)
@@ -8862 +8902 @@
   (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)

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

@@ -1 +1 @@
 (in-package :extensions)
+
+(require :java)
 
 (defvar *gui-backend* :swing)

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

@@ -337 +337 @@
   class
   (%register-java-class
-   jclass (mop::ensure-class (make-symbol (jclass-name jclass))
-           :metaclass (find-class 'java-class)
-           :direct-superclasses (if (jclass-superclass-p jclass (jclass "java.lang.Object"))
-                  (list (find-class 'java-object))
-                  (mapcar #'ensure-java-class
-                    (delete nil
-                      (concatenate 'list (list (jclass-superclass jclass))
-                       (jclass-interfaces jclass)))))
-           :java-class jclass)))))
-    
+   jclass (mop::ensure-class
+     (make-symbol (jclass-name jclass))
+     :metaclass (find-class 'java-class)
+     :direct-superclasses
+     (if (jclass-superclass-p jclass (jclass "java.lang.Object"))
+         (list (find-class 'java-object))
+         (mapcar #'ensure-java-class
+           (delete nil
+             (concatenate 'list (list (jclass-superclass jclass))
+              (jclass-interfaces jclass)))))
+     :java-class jclass)))))
+
 (defmethod make-instance ((class java-class) &rest initargs &key &allow-other-keys)
   (declare (ignore initargs))

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

@@ -39 +39 @@
              (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
@@ -51 +52 @@
              (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))
+  (let (*fasl-loader*)
+    (%load-returning-last-result (if (streamp filespec)
+             filespec
+             (merge-pathnames (pathname filespec)))
+         verbose print if-does-not-exist)))

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

@@ -33 +33 @@
 
 
-(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))
@@ -87 +84 @@
 (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)
@@ -95 +92 @@
 (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)

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

@@ -32 +32 @@
 (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)
@@ -44 +44 @@
          :format-arguments (list name)))
 
+(defvar *inline-declarations* nil)
 (defvar *declaration-types* (make-hash-table :test 'eq))
 
@@ -92 +93 @@
     ((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))

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

@@ -68 +68 @@
                  (HASH-TABLE)
                  (INTEGER RATIONAL)
+     (JAVA-CLASS STANDARD-CLASS)
                  (KEYWORD SYMBOL)
                  (LIST SEQUENCE)