[armedbear-cvs] r12630 - branches/less-reflection/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Fri Apr 23 21:23:03 UTC 2010
Author: astalla
Date: Fri Apr 23 17:23:02 2010
New Revision: 12630
Log:
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.
Modified:
branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java
branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java
branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/gui.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/load.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/proclaim.lisp
branches/less-reflection/abcl/src/org/armedbear/lisp/subtypep.lisp
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java Fri Apr 23 17:23:02 2010
@@ -683,6 +683,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");
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java Fri Apr 23 17:23:02 2010
@@ -2362,6 +2362,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_ =
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java Fri Apr 23 17:23:02 2010
@@ -278,7 +278,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");
}
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Fri Apr 23 17:23:02 2010
@@ -45,12 +45,21 @@
*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)
+ (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 +78,15 @@
(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)
@@ -168,7 +180,9 @@
compiled-function)
(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
,doc))
@@ -241,14 +255,16 @@
(if (special-operator-p name)
`(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)))))))))
(DEFTYPE
@@ -348,8 +364,9 @@
;; 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)))
(eval form))))
(declaim (ftype (function (t) t) convert-ensure-method))
@@ -379,7 +396,8 @@
(declare (ignore result))
(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...
(format *error-output* "; Unable to compile method~%")))))))))
@@ -425,7 +443,7 @@
(declare (ignore result))
(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*)))))
@@ -565,19 +583,38 @@
;; write header
(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)
(%stream-terpri out)
(write (list 'setq '*source* *compile-file-truename*)
: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))
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Apr 23 17:23:02 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
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Apr 23 17:23:02 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")
@@ -2174,12 +2176,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+)
+ (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))))
@@ -2330,6 +2342,7 @@
(java:java-object-p obj)))
(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*)))
;; The readObjectFromString call may require evaluation of
@@ -5315,7 +5328,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))
@@ -7891,6 +7905,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))))|#
(defknown p2-char= (t t t) t)
(defun p2-char= (form target representation)
@@ -8861,6 +8901,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)
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/gui.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/gui.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/gui.lisp Fri Apr 23 17:23:02 2010
@@ -1,5 +1,7 @@
(in-package :extensions)
+(require :java)
+
(defvar *gui-backend* :swing)
(defun init-gui ()
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp Fri Apr 23 17:23:02 2010
@@ -336,16 +336,18 @@
(if class
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))
(error "make-instance not supported for ~S" class))
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/load.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/load.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/load.lisp Fri Apr 23 17:23:02 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: branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp Fri Apr 23 17:23:02 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)))))
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/proclaim.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/proclaim.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/proclaim.lisp Fri Apr 23 17:23:02 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)
Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/subtypep.lisp
==============================================================================
--- branches/less-reflection/abcl/src/org/armedbear/lisp/subtypep.lisp (original)
+++ branches/less-reflection/abcl/src/org/armedbear/lisp/subtypep.lisp Fri Apr 23 17:23:02 2010
@@ -67,6 +67,7 @@
(GENERIC-FUNCTION FUNCTION)
(HASH-TABLE)
(INTEGER RATIONAL)
+ (JAVA-CLASS STANDARD-CLASS)
(KEYWORD SYMBOL)
(LIST SEQUENCE)
(LONG-FLOAT FLOAT)
More information about the armedbear-cvs
mailing list