[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