# HG changeset patch
# User Alan Ruttenberg <alanruttenberg@gmail.com>
# Date 1477731360 14400
#      Sat Oct 29 04:56:00 2016 -0400
# Node ID 620a834d38743096b6c64e39c318578fd8657d23
# Parent  ad2cf4edd552c42160371182af5f05843fa39d59
precompiler: possibly optimize lambda in function position (Alan Ruttenberg)

---
Notes from testing on 17-NOV-2016

The current patch has the following additional ANSI-TEST failures:

LAMBDA.1, LAMBDA.2, LAMBDA.3, LAMBDA.4, LAMBDA.5, LAMBDA.6, LAMBDA.7,
LAMBDA.8, LAMBDA.9, LAMBDA.10, LAMBDA.21, LAMBDA.22, LAMBDA.54,
LAMBDA.57, LAMBDA.63, LAMBDA.64

The ANSI tests require that the [ansi-tests][1] be manually installed
as a sibling directory of the ABCL build directory named 'ansi-test'.

[1]: git+https://gitlab.common-lisp.net/ansi-test/ansi-test.git

Then one may invoke the ANSI-TESTS via

    CL-USER> (asdf:load-system :abcl)(asdf:test-system :ansi-compiled)

Unfortunately the optimization for JSS requires that all necessary
Java objects have resolvable linkage at compile time, something that
wasn't required before.

The optimization for JSS is controlled by the
JSS:*INHIBIT-JSS-OPTIMIZATION* boolean, which is now true by default.
To try out this optimization

    (setf JSS:*INHIBIT-JSS-OPTIMIZATION* t)

---

Precompiler: When compiling a form with a lambda in the function
position, possibly optimize it

Case 1: If the lambda has a single form in it, let someone define a
transform using:

define-function-position-lambda-transform (body-function-name (arglist form args) &body body)

body-function-name is the car of the single form in the lambda
arglist is the arglist of the lambda
form is the single form within the lambda
args are the arguments to which the lambda will be defined.

The function should check whether it can do a transform, and do it if
so, otherwise return nil signalling it couldn't

Case 2: If case 1 is not successful then if the arglist is a simple
one (no &key, &rest, &optional) then do a standard beta-reduction
binding the args to arglist using let (https://wiki.haskell.org/Beta_reduction)

If not, return and do the usual thing.

An example is in contrib/jss/optimize-java-call.lisp

To see benefits, (compile-file contrib/jss/test-optimize-java-call.lisp)
and then load the compiled file. You should see something like the below
which reports the timings for the optimized and unoptimized version of
10000 calls of (#"compile" 'regex.pattern ".*")

--

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

See:
https://mailman.common-lisp.net/pipermail/armedbear-devel/2016-October/003726.html
https://mailman.common-lisp.net/pipermail/armedbear-devel/2016-November/003733.html

diff -r ad2cf4edd552 contrib/jss/invoke.lisp
--- a/contrib/jss/invoke.lisp	Thu Nov 17 11:36:44 2016 +0100
+++ b/contrib/jss/invoke.lisp	Thu Nov 17 11:41:41 2016 +0100
@@ -288,8 +288,8 @@
                               (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)))
diff -r ad2cf4edd552 contrib/jss/jss.asd
--- a/contrib/jss/jss.asd	Thu Nov 17 11:36:44 2016 +0100
+++ b/contrib/jss/jss.asd	Thu Nov 17 11:41:41 2016 +0100
@@ -1,8 +1,8 @@
 ;;;; -*- 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")
diff -r ad2cf4edd552 contrib/jss/optimize-java-call.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/contrib/jss/optimize-java-call.lisp	Thu Nov 17 11:41:41 2016 +0100
@@ -0,0 +1,36 @@
+(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)))))
+
diff -r ad2cf4edd552 contrib/jss/packages.lisp
--- a/contrib/jss/packages.lisp	Thu Nov 17 11:36:44 2016 +0100
+++ b/contrib/jss/packages.lisp	Thu Nov 17 11:41:41 2016 +0100
@@ -3,6 +3,7 @@
   (:use :common-lisp :extensions :java)
   (:export 
    #:*inhibit-add-to-classpath*
+   #:*inhibit-jss-optimization*
    #:*added-to-classpath*
    #:*do-auto-imports*
    #:*muffle-warnings*
diff -r ad2cf4edd552 contrib/jss/test-optimize-java-call.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/contrib/jss/test-optimize-java-call.lisp	Thu Nov 17 11:41:41 2016 +0100
@@ -0,0 +1,44 @@
+(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
+|#
diff -r ad2cf4edd552 src/org/armedbear/lisp/precompiler.lisp
--- a/src/org/armedbear/lisp/precompiler.lisp	Thu Nov 17 11:36:44 2016 +0100
+++ b/src/org/armedbear/lisp/precompiler.lisp	Thu Nov 17 11:41:41 2016 +0100
@@ -382,8 +382,9 @@
   (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,6 +400,34 @@
           (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))
