<div dir="ltr">I got curious about how I might generate better code for JSS. <div><br><div>The JSS reader macro generates a lambda, so the typical pattern one sees is:</div><div><font face="monospace, monospace"><br></font></div><div><font face="monospace, monospace">(#"matches" 'integer ".*a" )<br></font></div><div><font face="monospace, monospace">-></font></div><div><div><font face="monospace, monospace">((LAMBDA (#:|#"matches"-first| &REST #:|#"matches"-rest|)</font></div><div><font face="monospace, monospace">   (JSS:INVOKE-RESTARGS "matches"</font></div><div><font face="monospace, monospace">                        #:|#"matches"-first|</font></div><div><font face="monospace, monospace">                        #:|#"matches"-rest|</font></div><div><font face="monospace, monospace">                        NIL))</font></div><div><font face="monospace, monospace"> 'INTEGER ".*a")</font></div></div><div><br></div><div>(yes I know this will generate an error at runtime)</div><div><br></div><div>Right now the compiled code for one such call goes through 3 functions:</div><div><font face="monospace, monospace"><br></font></div><div><div><font face="monospace, monospace">(JSTATIC "matches" #<java class java.lang.Integer {3BBD30F}> ".*a")</font></div><div><font face="monospace, monospace">(APPLY #<JSTATIC {41D16045}> "matches" #<java class java.lang.Integer {3BBD30F}> (".*a"))</font></div><div><font face="monospace, monospace">(INVOKE-RESTARGS "matches" INTEGER (".*a") NIL)</font></div></div><div><br></div><div>Really we only need: <span style="font-family:monospace,monospace">(JSTATIC "matches" #<java class java.lang.Integer {3BBD30F}> ".*a")</span></div><div>and we know enough at compile time to generate that form.</div><div><br></div><div>If only I could figure out where the right hook would be.</div><div><br></div><div>The only place I could figure to do this is in precompile-function-call [1]</div><div><br></div><div>With a hook in place, i define the hook as [2]</div><div><br></div><div><div>After checking if the function call is one of the JSS ones, the hook transforms </div><div><br></div><div> ((lambda(a b ) (jss::invoke-restargs-experimental method a b raw?) c d) </div><div>to</div><div>(jss::invoke-restargs-experimental method c '(d) raw? t)  <br></div><div><br></div><div>jss::invoke-restargs-experimental is macro that does the transformation I want. [3]<br></div></div><div><br></div><div>The question is: Is there a more elegant way to do this, or a hook already built that I could use instead of redefining <span style="font-family:monospace,monospace">precompile-function-call</span></div><br>If not, would it be reasonable to add a hook in the ABCL source so I don't need to patch it to do the optimization.</div><div><br></div><div>Thanks,</div><div>Alan<br><div><br></div><div><br></div><div>[1]</div><div><br></div><div><div><font face="monospace, monospace">(defun precompile-function-call (form)</font></div><div><font face="monospace, monospace">  (let ((op (car form)))</font></div><div><font face="monospace, monospace">    (when (and (consp op) (eq (%car op) 'LAMBDA))</font></div><div><font face="monospace, monospace">      (return-from precompile-function-call</font></div><div><span class="gmail-Apple-tab-span" style="white-space:pre"><font face="monospace, monospace"><br></font></span></div><div><span style="white-space:pre"><font face="monospace, monospace">I added this line </font></span></div><div><span style="white-space:pre"><font face="monospace, monospace"><br></font></span></div><div><span style="white-space:pre"><font face="monospace, monospace">---</font></span></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">      </span>(or (jss-fix-precompile op (mapcar #'precompile1 (cdr form)))<br></font></div><div><font face="monospace, monospace">--- <br></font></div><div><font face="monospace, monospace">                   (cons (precompile-lambda op)</font></div><div><font face="monospace, monospace">                         (mapcar #'precompile1 (cdr form))))))</font></div><div><font face="monospace, monospace">    (when (or (not *in-jvm-compile*) (notinline-p op))</font></div><div><font face="monospace, monospace">      (return-from precompile-function-call (precompile-cons form)))</font></div><div><font face="monospace, monospace">    (when (source-transform op)</font></div><div><font face="monospace, monospace">      (let ((new-form (expand-source-transform form)))</font></div><div><font face="monospace, monospace">        (when (neq new-form form)</font></div><div><font face="monospace, monospace">          (return-from precompile-function-call (precompile1 new-form)))))</font></div><div><font face="monospace, monospace">    (when *enable-inline-expansion*</font></div><div><font face="monospace, monospace">      (let ((expansion (inline-expansion op)))</font></div><div><font face="monospace, monospace">        (when expansion</font></div><div><font face="monospace, monospace">          (let ((explain *explain*))</font></div><div><font face="monospace, monospace">            (when (and explain (memq :calls explain))</font></div><div><font face="monospace, monospace">              (format t ";   inlining call to ~S~%" op)))</font></div><div><font face="monospace, monospace">          (return-from precompile-function-call (precompile1 (expand-inline form expansion))))))</font></div><div><font face="monospace, monospace">    (cons op (mapcar #'precompile1 (cdr form)))))</font></div></div><div><br></div><div>[2]</div><div><div><font face="monospace, monospace"><br></font></div><div><font face="monospace, monospace">(defun jss-fix-precompile (op args)</font></div><div><font face="monospace, monospace">  "Check if this is one of mine, and do the rewrite, otherwise pass"</font></div><div><font face="monospace, monospace">  (ignore-errors </font></div><div><font face="monospace, monospace">  (let ((body (cddr op)))</font></div><div><font face="monospace, monospace">    (if (and (= (length body) 1)</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">      </span>     (consp (car body))</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">       </span>     (eq (caar body) 'jss::invoke-restargs-experimental))</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre"> </span>(precompile-function-call `(jss::invoke-restargs-experimental ,(second (car body)) ,(car args) ,(cdr args) ,(fifth (car body)) t))</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">      </span>nil))))</font></div></div><div><br></div><div>[3]</div><div><br></div><div><div><font face="monospace, monospace">(defmacro invoke-restargs-experimental (&whole form method object args &optional (raw? nil) (precompile nil))</font></div><div><font face="monospace, monospace">  "If I'm precompiling then I can do the transformation. If not I revert to the original method"</font></div><div><font face="monospace, monospace">  (if precompile</font></div><div><font face="monospace, monospace">      (if (and (consp object) (eq (car object) 'quote))</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">   </span>  (let ((object (eval object)))</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">        </span>    (let* ((object-as-class-name </font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">            </span>     (if (symbolp object)</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">                     </span> (maybe-resolve-class-against-imports object)</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">                   </span> ))</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">             </span>   (object-as-class </font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">          </span>     (if object-as-class-name (find-java-class object-as-class-name))))</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">       </span>      (cl-user::print-db object object-as-class-name object-as-class)</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">        </span>      (if raw?</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">               </span>  `(jstatic-raw ,method ,object-as-class ,@args)</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">               </span>  `(jstatic ,method ,object-as-class ,@args))))</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">        </span>  (if raw?</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">     </span>      `(if (symbolp ,object)</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">         </span>   (jstatic-raw ,method (find-java-class ,object) ,@args)</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">              </span>   (jcall-raw ,method ,object ,@args))</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre"> </span>      `(if (symbolp ,object)</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">         </span>   (jstatic ,method (find-java-class ,object) ,@args)</font></div><div><font face="monospace, monospace"><span class="gmail-Apple-tab-span" style="white-space:pre">          </span>   (jcall ,method ,object ,@args))))</font></div><div><font face="monospace, monospace">      `(invoke-restargs ,method ,object ,args ,raw?)))</font></div></div><div><br></div></div></div>