Ticket #420: beta-reduce-20161117a.diff

contrib/jss/invoke.lisp

@@ -288 +288 @@
                               (group "group"))
       (loop while (hasmore entries)
          for name =  (getname (next entries))
-         with class-pattern = (#"compile" '|java.util.regex.Pattern| ".*\\.class$")
-         with name-pattern = (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$")
+         with class-pattern = (jstatic "compile" "java.util.regex.Pattern" ".*\\.class$")
+         with name-pattern = (jstatic "compile" "java.util.regex.Pattern" ".*?([^.]*)$")
          when (matches (matcher class-pattern name))
          collect
            (let* ((fullname (substring (jreplace name #\/ #\.) 0 (- (jlength name) 6)))

contrib/jss/jss.asd

@@ -1 +1 @@
 ;;;; -*- Mode: LISP -*-
 (asdf:defsystem :jss
   :author "Alan Ruttenberg, Mark Evenson"
-  :version "3.1.1" 
-  :description "<> asdf:defsystem <urn:abcl.org/release/1.5.0/contrib/jss#3.1.1>"
+  :version "3.2.0" 
+  :description "<> asdf:defsystem <urn:abcl.org/release/1.5.0/contrib/jss#3.2.0>"
   :components ((:module base 
                         :pathname "" :serial t 
                         :components ((:file "packages")

new file contrib/jss/optimize-java-call.lisp

@@ +1 @@
+(in-package :jss)
+
+(defvar *inhibit-jss-optimization* t)
+
+;; https://mailman.common-lisp.net/pipermail/armedbear-devel/2016-October/003726.html
+
+(precompiler::define-function-position-lambda-transform jss::invoke-restargs (arglist form args)
+  (declare (ignore arglist))
+  (unless *inhibit-jss-optimization*
+    (precompiler::precompile-function-call 
+     `(jss::invoke-restargs-macro
+    ,(second form)
+    ,(car args) (list ,@(cdr args)) ,(fifth form)))))
+
+(defmacro invoke-restargs-macro ( method object args &optional (raw? nil))
+  (assert (eq (car args) 'list))
+  (setq args (cdr args))
+  (if (and (consp object) (eq (car object) 'quote))
+      (let ((object (eval object)))
+  (let* ((object-as-class-name
+     (if (symbolp object)
+         (jss::maybe-resolve-class-against-imports object)
+         ))
+         (object-as-class
+     (if object-as-class-name (find-java-class object-as-class-name))))
+    (if raw?
+        `(jstatic-raw ,method ,object-as-class ,@args)
+        `(jstatic ,method ,object-as-class ,@args))))
+      (if raw?
+    `(if (symbolp ,object)
+         (jstatic-raw ,method (find-java-class ,object) ,@args)
+         (jcall-raw ,method ,object ,@args))
+    `(if (symbolp ,object)
+         (jstatic ,method (find-java-class ,object) ,@args)
+         (jcall ,method ,object ,@args)))))
+

contrib/jss/packages.lisp

@@ -3 +3 @@
   (:use :common-lisp :extensions :java)
   (:export 
    #:*inhibit-add-to-classpath*
+   #:*inhibit-jss-optimization*
    #:*added-to-classpath*
    #:*do-auto-imports*
    #:*muffle-warnings*

new file contrib/jss/test-optimize-java-call.lisp

@@ +1 @@
+(in-package :jss)
+
+(format t "~%~%")
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (setq *inhibit-jss-optimization* nil)
+  (format t "With optimization: ~s~%" (macroexpand (precompiler::precompile-form '(#"compile" 'regex.Pattern ".*") t))))
+
+(defun optimized-jss (count)
+  (loop repeat count do (#"compile" 'regex.Pattern ".*")))
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (setq *inhibit-jss-optimization* t)
+  (format t "Without optimization: ~s~%" (precompiler::precompile-form '(#"compile" 'regex.Pattern ".*") t)))
+
+(defun unoptimized-jss (count)
+  (loop repeat count do (#"compile" 'regex.Pattern ".*")))
+
+(defun just-loop (count)
+  (loop repeat count))
+
+(print 'just-loop)
+(time (just-loop 10000))
+(print 'first)
+(time (optimized-jss 10000))
+(print 'second)
+(time (unoptimized-jss 10000))
+
+#|
+With optimization: (INVOKE-RESTARGS-MACRO "compile" (QUOTE REGEX.PATTERN) (LIST ".*") NIL T)
+Without optimization: ((LAMBDA (#:G85648 &REST #:G85649) (INVOKE-RESTARGS "compile" #:G85648 #:G85649 NIL)) (QUOTE REGEX.PATTERN) ".*")
+
+JUST-LOOP 
+0.0 seconds real time
+0 cons cells
+
+OPTIMIZED-JSS
+0.011 seconds real time
+0 cons cells
+
+UNOPTIMIZED-JSS
+0.325 seconds real time
+800156 cons cells
+|#

src/org/armedbear/lisp/precompiler.lisp

@@ -382 +382 @@
   (let ((op (car form)))
     (when (and (consp op) (eq (%car op) 'LAMBDA))
       (return-from precompile-function-call
-                   (cons (precompile-lambda op)
-                         (mapcar #'precompile1 (cdr form)))))
+  (or (precompile-function-position-lambda op (cdr form))
+      (cons (precompile-lambda op)
+      (mapcar #'precompile1 (cdr form))))))
     (when (or (not *in-jvm-compile*) (notinline-p op))
       (return-from precompile-function-call (precompile-cons form)))
     (when (source-transform op)
@@ -399 +400 @@
           (return-from precompile-function-call (precompile1 (expand-inline form expansion))))))
     (cons op (mapcar #'precompile1 (cdr form)))))
 
+(defun precompile-function-position-lambda (lambda args)
+  (let* ((arglist (second lambda))
+   (body (cddr lambda))
+   (simple-arglist? (not (or (memq '&KEY arglist) (memq '&OPTIONAL arglist) (memq '&REST arglist)))))
+    (or
+     ;;give a chance for someone to transform single-form function bodies
+     (and (= (length body) 1) (consp (car body)) (get (caar body) 'sys::function-position-lambda-transform)
+    (funcall (get (caar body) 'sys::function-position-lambda-transform) (caar body) (car body) (mapcar #'precompile1 args)))
+     (and simple-arglist?
+    (let ((arglist-length (if (memq '&aux arglist) (position '&aux arglist) (length arglist))))
+      (if (= (length args) arglist-length)
+    ;; simplest case - we have a simple arglist with as many
+    ;; arguments as call args. Transform to let.
+    (return-from precompile-function-position-lambda
+      `((let* ,(append
+          (loop for arg-name in arglist
+          for arg in (mapcar #'precompile1 args)
+          until (eq arg-name '&aux)
+          collect (list arg-name arg))
+          (subseq arglist (1+ arglist-length)))
+          ,@body)))
+    (error "Argument mismatch for lambda in function position: ~a applied to ~a" `(lambda ,arglist body) args)))))))
+
+(defmacro define-function-position-lambda-transform (body-function-name (arglist form args) &body body)
+  `(put ',body-function-name 'sys::function-position-lambda-transform 
+  #'(lambda(,arglist ,form ,args)
+      ,@body)))
+
 (defun precompile-locally (form)
   (let ((*inline-declarations* *inline-declarations*))
     (process-optimization-declarations (cdr form))