Changeset 14911

11/17/16 19:22:56 (5 years ago)
Mark Evenson

precompiler: possibly beta reduce form with function position lambda (Alan Ruttenberg)

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 (

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) ".*")

0.0 seconds real time
0 cons cells

0.011 seconds real time
0 cons cells

0.325 seconds real time
800156 cons cells

<> rdfs:seeAlso <>
<> rdfs:seeAlso <> .
<> :fixes <> .
<> :closes <> .
<> :closes <> .

2 added
3 edited


  • trunk/abcl/contrib/jss/invoke.lisp

    r14910 r14911  
    126126(defvar *muffle-warnings* t)
     128(defvar *muffle-warnings* t)
    128130(defvar *imports-resolved-classes* (make-hash-table :test 'equalp))
    289291      (loop while (hasmore entries)
    290292         for name =  (getname (next entries))
    291          with class-pattern = (#"compile" '|java.util.regex.Pattern| ".*\\.class$")
    292          with name-pattern = (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$")
     293         with class-pattern = (jstatic "compile" "java.util.regex.Pattern" ".*\\.class$")
     294         with name-pattern = (jstatic "compile" "java.util.regex.Pattern" ".*?([^.]*)$")
    293295         when (matches (matcher class-pattern name))
    294296         collect
  • trunk/abcl/contrib/jss/jss.asd

    r14910 r14911  
    22(asdf:defsystem :jss
    33  :author "Alan Ruttenberg, Mark Evenson"
    4   :version "3.1.1"
    5   :description "<> asdf:defsystem <>"
     4  :version "3.2.0"
     5  :description "<> asdf:defsystem <>"
    66  :components ((:module base
    77                        :pathname "" :serial t
    88                        :components ((:file "packages")
    99                                     (:file "invoke")
     10             (:file "optimize-java-call")
    1011                                     (:file "classpath")
    1112                                     (:file "compat")))))
  • trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

    r14763 r14911  
    383383    (when (and (consp op) (eq (%car op) 'LAMBDA))
    384384      (return-from precompile-function-call
    385                    (cons (precompile-lambda op)
    386                          (mapcar #'precompile1 (cdr form)))))
     385  (or (precompile-function-position-lambda op (cdr form))
     386      (cons (precompile-lambda op)
     387      (mapcar #'precompile1 (cdr form))))))
    387388    (when (or (not *in-jvm-compile*) (notinline-p op))
    388389      (return-from precompile-function-call (precompile-cons form)))
    399400          (return-from precompile-function-call (precompile1 (expand-inline form expansion))))))
    400401    (cons op (mapcar #'precompile1 (cdr form)))))
     403(defun precompile-function-position-lambda (lambda args)
     404  (let* ((arglist (second lambda))
     405   (body (cddr lambda))
     406   (simple-arglist? (not (or (memq '&KEY arglist) (memq '&OPTIONAL arglist) (memq '&REST arglist)))))
     407    (or
     408     ;;give a chance for someone to transform single-form function bodies
     409     (and (= (length body) 1) (consp (car body)) (get (caar body) 'sys::function-position-lambda-transform)
     410    (funcall (get (caar body) 'sys::function-position-lambda-transform) (caar body) (car body) (mapcar #'precompile1 args)))
     411     (and simple-arglist?
     412    (let ((arglist-length (if (memq '&aux arglist) (position '&aux arglist) (length arglist))))
     413      (if (= (length args) arglist-length)
     414    ;; simplest case - we have a simple arglist with as many
     415    ;; arguments as call args. Transform to let.
     416    (return-from precompile-function-position-lambda
     417      `(let* ,(append
     418          (loop for arg-name in arglist
     419          for arg in (mapcar #'precompile1 args)
     420          until (eq arg-name '&aux)
     421          collect (list arg-name arg))
     422          (subseq arglist (1+ arglist-length)))
     423          ,@body))
     424    (error "Argument mismatch for lambda in function position: ~a applied to ~a" `(lambda ,arglist body) args)))))))
     426(defmacro define-function-position-lambda-transform (body-function-name (arglist form args) &body body)
     427  `(put ',body-function-name 'sys::function-position-lambda-transform
     428  #'(lambda(,arglist ,form ,args)
     429      ,@body)))
    402431(defun precompile-locally (form)
Note: See TracChangeset for help on using the changeset viewer.