[armedbear-devel] "Hardcoding" methods that funcall a symbol
Theam Yong Chew
senatorzergling at gmail.com
Sun Dec 15 13:33:44 UTC 2013
Hi all,
This is old history, but I remember seeing some really old email
threads about hardcoding of Lisp function (as symbols) calls into Java
methods. Attached please find a patch for trying this out. I
refactored the original method body generation code slightly, then
added java::runtime-class-add-symbol-method-body which involves low
level bytecode generation, so I'd appreciate additional checks/reviews
(I believe the repetitive load/store sequences won't have any effects
with the JIT & optimisers, but may be fractionally easier to
decompile...).
I also updated java:jnew-runtime-class's docstring, but I'm not sure
if the wording "function designator" is accurate enough, since
(funcall '(lambda () 1)) => 1
Would '(lambda () 1) be considered a FUNCTION DESIGNATOR? In any case,
java::runtime-class-add-methods already works with it just the same.
This code has not been rigorously tested as it doesn't work in
abcl-1.2.1 (tested/works for older versions) due to a regression,
since fixed in r14570 (Restore Packages.findPackage() API...Fixes
#324).
See appendix, where I include a start for some tests. And in case it
isn't obvious, the hardcoding of symbol funcalls (test3) into a class
method is the only new functionality here.
Yong
(defun test3 (this)
"test3")
(defun test4 (this x y z)
(+ x y z))
(defparameter *test-class*
(java:jnew-runtime-class
"runtime_class"
:methods `(("test1" "java.lang.String" () ,(lambda (this) "test1"))
("test2" "java.lang.String" () (lambda (this) "test2"))
("test3" "java.lang.String" () test3)
("test4" "java.lang.Object"
;; (:int :int :int) ;; unsupported for now
("java.lang.Object" "java.lang.Object"
"java.lang.Object")
,(function test4))
("test5" "java.lang.String"
("java.lang.String")
(lambda (this x) (declare (ignore x)) "test5"))
("undefined" :void () undefined))))
(let ((obj (java:jnew *test-class*)))
(list (java:jcall "test1" obj)
(java:jcall "test2" obj)
(java:jcall "test3" obj)
(java:jcall "test4" obj 1 2 3)
(java:jcall "test5" obj "foo")))
==> ("test1" "test2" "test3" 6 "test5")
;; This should thrown an error...
(java:jcall "undefined" (java:jnew *test-class*))
;; As should this, but java.lang.NoSuchMethodException: No applicable
method is not very obvious...
(java:jcall "test5" (java:jnew *test-class*))
;; This shouldn't, but does, see stack trace below, (quite relatedly,
at least for me using Slime, (java:jcall "undefined" (java:jnew
*test-class*)) above actually seemed to throw 2 errors)
(ignore-errors (java:jcall "undefined" (java:jnew *test-class*)))
==> ;;error
Java exception 'org.armedbear.lisp.Go'.
[Condition of type JAVA:JAVA-EXCEPTION]
Restarts:
0: [RETRY] Retry SLIME interactive evaluation request.
1: [*ABORT] Return to SLIME's top level.
2: [ABORT] Abort thread.
Backtrace:
0: (#<FUNCTION {106FAF1E}> #<JAVA-EXCEPTION {658A7B6C}> #<FUNCTION
{106FAF1E}>)
Locals:
"??" = #<FUNCTION {106FAF1E}>
"??"#1 = #<JAVA:JAVA-EXCEPTION org.armedbear.lisp.Go {658A7B6C}>
"??"#2 = #<FUNCTION {106FAF1E}>
1: (APPLY #<FUNCTION {106FAF1E}> (#<JAVA-EXCEPTION {658A7B6C}>
#<FUNCTION {106FAF1E}>))
Locals:
"??" = APPLY
"??"#1 = #<FUNCTION {106FAF1E}>
"??"#2 = (#<JAVA:JAVA-EXCEPTION org.armedbear.lisp.Go {658A7B6C}> ..)
2: (SYSTEM::RUN-HOOK SYSTEM::*INVOKE-DEBUGGER-HOOK* #<JAVA-EXCEPTION
{658A7B6C}> #<FUNCTION {106FAF1E}>)
Locals:
"??" = SYSTEM::RUN-HOOK
"??"#1 = SYSTEM::*INVOKE-DEBUGGER-HOOK*
"??"#2 = #<JAVA:JAVA-EXCEPTION org.armedbear.lisp.Go {658A7B6C}>
"??"#3 = #<FUNCTION {106FAF1E}>
3: (INVOKE-DEBUGGER #<JAVA-EXCEPTION {658A7B6C}>)
Locals:
"??" = INVOKE-DEBUGGER
"??"#1 = #<JAVA:JAVA-EXCEPTION org.armedbear.lisp.Go {658A7B6C}>
4: org.armedbear.lisp.Lisp.error(Lisp.java:382)
Locals:
"??" = "??"
5: org.armedbear.lisp.Java.jcall(Java.java:909)
Locals:
"??" = "??"
6: org.armedbear.lisp.Java$pf_jcall.execute(Java.java:756)
Locals:
"??" = :CLASS
"??"#1 = "org.armedbear.lisp.Java$pf_jcall"
"??"#2 = :METHOD
"??"#3 = "execute"
"??"#4 = :FILE
"??"#5 = "Java.java"
"??"#6 = :LINE
"??"#7 = 756
7: org.armedbear.lisp.Primitive.execute(Primitive.java:123)
Locals:
"??" = :CLASS
"??"#1 = "org.armedbear.lisp.Primitive"
"??"#2 = :METHOD
"??"#3 = "execute"
"??"#4 = :FILE
"??"#5 = "Primitive.java"
"??"#6 = :LINE
"??"#7 = 123
8: (JAVA:JCALL "undefined" #<runtime_class runtime_class at 1451e300 {C0E1F6C}>)
Locals:
"??" = JAVA:JCALL
"??"#1 = "undefined"
"??"#2 = #<runtime_class runtime_class at 1451e300 {C0E1F6C}>
9: (#<FUNCTION (LAMBDA ()) {7330F1A2}>)
Locals:
"??" = #<FUNCTION (LAMBDA ()) {7330F1A2}>
10: (JAVA:JRUN-EXCEPTION-PROTECTED #<FUNCTION (LAMBDA ()) {7330F1A2}>)
11: (SYSTEM::%EVAL (IGNORE-ERRORS (JAVA:JCALL "undefined" (JAVA:JNEW
*TEST-CLASS*))))
12: (EVAL (IGNORE-ERRORS (JAVA:JCALL "undefined" (JAVA:JNEW *TEST-CLASS*))))
13: (#<FUNCTION {1247FDC3}>)
-------------- next part --------------
Index: src/org/armedbear/lisp/runtime-class.lisp
===================================================================
--- src/org/armedbear/lisp/runtime-class.lisp (revision 14590)
+++ src/org/armedbear/lisp/runtime-class.lisp (working copy)
@@ -30,7 +30,7 @@
Method definitions are lists of the form
(method-name return-type argument-types function &key modifiers annotations)
where method-name is a string, return-type and argument-types are strings or keywords for
- primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity
+ primitive types (:void, :int, etc.), and function is a Lisp function designator of minimum arity
(1+ (length argument-types)); the instance (`this') is passed in as the first argument.
Field definitions are lists of the form (field-name type &key modifiers annotations)."
@@ -116,59 +116,104 @@
(t
(error "Unsupported return type: ~A" return-type))))
+(defun java::runtime-class-common-add-method-boxer (argument-types)
+ (let ((argc (length argument-types)))
+ ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
+ (dotimes (i (* 2 (1+ argc)))
+ (allocate-register nil))
+ ;;Box "this" (to be passed as the first argument to the Lisp function)
+ (aload 0)
+ (emit 'iconst_1) ;;true
+ (emit-invokestatic +abcl-java-object+ "getInstance"
+ (list +java-object+ :boolean) +lisp-object+)
+ (astore (1+ argc))
+ ;;Box each argument
+ (loop
+ :for arg-type :in argument-types
+ :for i :from 1
+ :do (progn
+ (cond
+ ((keywordp arg-type)
+ (error "Unsupported arg-type: ~A" arg-type))
+ ((eq arg-type :int) :todo)
+ (t (aload i)
+ (emit 'iconst_1) ;;true
+ (emit-invokestatic +abcl-java-object+ "getInstance"
+ (list +java-object+ :boolean) +lisp-object+)))
+ (astore (+ i (1+ argc)))))))
+
+(defun java::runtime-class-common-add-method-return (argument-types return-type)
+ (let ((argc (length argument-types)))
+ (if (<= (1+ argc) call-registers-limit)
+ (progn
+ ;;Load the boxed this
+ (aload (1+ argc))
+ ;;Load each boxed argument
+ (dotimes (i argc)
+ (aload (+ argc 2 i))))
+ (error "execute(LispObject[]) is currently not supported")))
+ (emit-call-execute (1+ (length argument-types)))
+ (java::emit-unbox-and-return return-type))
+
+(defun java::runtime-class-add-normal-method-body (function class-file field-name argument-types return-type)
+ (java::runtime-class-common-add-method-boxer argument-types)
+ ;;Load the Lisp function from its static field
+ (emit-getstatic (class-file-class class-file) field-name +lisp-object+)
+ (java::runtime-class-common-add-method-return argument-types return-type))
+
+(defun java::runtime-class-add-symbol-method-body (function class-file field-name argument-types return-type)
+ ;; symbol = org.armedbear.lisp.Packages.findPackage(<package>).findAccessibleSymbol(<symbol-name>)
+ (emit 'ldc (pool-add-string *pool* (package-name (symbol-package function))))
+ (emit-invokestatic +lisp-packages+
+ "findPackage"
+ (list +java-string+)
+ +lisp-package+)
+ (let* ((num-locals (* 2 (1+ (length argument-types))))
+ (local-var-1-index (+ 0 num-locals))
+ (local-var-2-index (+ 1 num-locals)))
+ (dotimes (i 2) (allocate-register nil))
+ (astore local-var-1-index)
+ (aload local-var-1-index)
+ (emit 'ldc (pool-add-string *pool* (symbol-name function)))
+ (emit-invokevirtual +lisp-package+
+ "findAccessibleSymbol"
+ (list +java-string+)
+ +lisp-symbol+)
+ (astore local-var-2-index)
+ (aload local-var-2-index))
+ (java::runtime-class-common-add-method-boxer argument-types)
+ (java::runtime-class-common-add-method-return argument-types return-type))
+
(defun java::runtime-class-add-methods (class-file methods)
+ "Lisp functions (lisp objects) are saved and referenced from
+ public static class fields, while symbols (function names) are
+ hardcoded into the method body to be funcalled. The user must
+ separately ensure the callee function is loaded/maintained within
+ the Lisp Interpreter. No additional handling is provided here for
+ serialising/deserialising the function definition. That means if
+ this class is loaded from a new Interpreter (for instance from a
+ class file), the method call will fail."
(let (method-implementation-fields)
(dolist (m methods)
(destructuring-bind (name return-type argument-types function
&key (modifiers '(:public)) annotations override) m
(let* ((argument-types (mapcar #'java::canonicalize-java-type argument-types))
- (argc (length argument-types))
(return-type (java::canonicalize-java-type return-type))
(jmethod (make-jvm-method name return-type argument-types :flags modifiers))
(field-name (string (gensym name))))
(class-add-method class-file jmethod)
- (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
- (class-add-field class-file field)
- (push (cons field-name function) method-implementation-fields))
+ (unless (symbolp function)
+ (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
+ (class-add-field class-file field)
+ (push (cons field-name function) method-implementation-fields)))
(when annotations
(method-add-attribute jmethod (make-runtime-visible-annotations-attribute
:list (mapcar #'parse-annotation annotations))))
(with-code-to-method (class-file jmethod)
- ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
- (dotimes (i (* 2 (1+ argc)))
- (allocate-register nil))
- ;;Box "this" (to be passed as the first argument to the Lisp function)
- (aload 0)
- (emit 'iconst_1) ;;true
- (emit-invokestatic +abcl-java-object+ "getInstance"
- (list +java-object+ :boolean) +lisp-object+)
- (astore (1+ argc))
- ;;Box each argument
- (loop
- :for arg-type :in argument-types
- :for i :from 1
- :do (progn
- (cond
- ((keywordp arg-type)
- (error "Unsupported arg-type: ~A" arg-type))
- ((eq arg-type :int) :todo)
- (t (aload i)
- (emit 'iconst_1) ;;true
- (emit-invokestatic +abcl-java-object+ "getInstance"
- (list +java-object+ :boolean) +lisp-object+)))
- (astore (+ i (1+ argc)))))
- ;;Load the Lisp function from its static field
- (emit-getstatic (class-file-class class-file) field-name +lisp-object+)
- (if (<= (1+ argc) call-registers-limit)
- (progn
- ;;Load the boxed this
- (aload (1+ argc))
- ;;Load each boxed argument
- (dotimes (i argc)
- (aload (+ argc 2 i))))
- (error "execute(LispObject[]) is currently not supported"))
- (emit-call-execute (1+ (length argument-types)))
- (java::emit-unbox-and-return return-type))
+ (funcall (if (symbolp function)
+ 'java::runtime-class-add-symbol-method-body
+ 'java::runtime-class-add-normal-method-body)
+ function class-file field-name argument-types return-type))
(cond
((eq override t)
(let ((super-method
Index: src/org/armedbear/lisp/jvm-class-file.lisp
===================================================================
--- src/org/armedbear/lisp/jvm-class-file.lisp (revision 14590)
+++ src/org/armedbear/lisp/jvm-class-file.lisp (working copy)
@@ -200,6 +200,7 @@
"org.armedbear.lisp.CompiledPrimitive")
(define-class-name +lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable")
(define-class-name +lisp-hash-table+ "org.armedbear.lisp.HashTable")
+(define-class-name +lisp-packages+ "org.armedbear.lisp.Packages")
(define-class-name +lisp-package+ "org.armedbear.lisp.Package")
(define-class-name +lisp-readtable+ "org.armedbear.lisp.Readtable")
(define-class-name +lisp-stream+ "org.armedbear.lisp.Stream")
@@ -1734,4 +1735,4 @@
|#
-(provide '#:jvm-class-file)
\ No newline at end of file
+(provide '#:jvm-class-file)
More information about the armedbear-devel
mailing list