summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-14 10:27:08 +0200
committerMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-14 10:27:08 +0200
commit743d74b2454c5c08db5f3b5a53593a6bdcc247d5 (patch)
tree69eb77f2518374bb35c2a5919faced1e2f84ecd7
parent2c2833352ee146c9fda294fbf455d6529f8374ee (diff)
Specialize function calls over the argument count (< 20).
-rw-r--r--sb-eval2.lisp58
1 files changed, 47 insertions, 11 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 0567318..7fb09b2 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -170,27 +170,63 @@
(defun prepare-nil ()
(lambda (env) (declare (ignore env))))
+(defmacro specialize (&environment env var value possible-values &body body)
+ `(ecase ,value
+ ,@(loop for x in (sb-int:eval-in-lexenv possible-values env)
+ collect
+ `((,x) ,(sb-int:eval-in-lexenv `(let ((,var ,x)) ,@body) env)))))
+
(declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-local-call))
(defun prepare-local-call (f args context)
(let* ((args* (mapcar (lambda (form) (prepare-form form context)) args))
(flex (context-find-function context f))
(offset (lexical-offset flex))
(nesting (lexical-nesting flex)))
- (lambda (env)
- (apply (the function (environment-value env nesting offset))
- (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))))
+ (if (< (length args) 20)
+ (specialize m% (length args) (loop for i from 0 below 20 collect i)
+ (let ((argvars (loop for i from 0 below m%
+ collect (gensym (format nil "ARG~D-" i)))))
+ `(let ,(loop for var in argvars
+ for i from 0 below m%
+ collect `(,var (nth ,i args*)))
+ (lambda (env)
+ (funcall (the function (environment-value env nesting offset))
+ ,@(loop for var in argvars
+ collect `(funcall (the eval-closure ,var) env)))))))
+ (lambda (env)
+ (apply (the function (environment-value env nesting offset))
+ (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))))
(declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-global-call))
(defun prepare-global-call (f args context)
(let ((args* (mapcar (lambda (form) (prepare-form form context)) args)))
- (if (fboundp f)
- (let ((f* (fdefinition f)))
- (lambda (env)
- (apply f*
- (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))
- (lambda (env)
- (apply (fdefinition f)
- (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))))
+ (if (< (length args) 20)
+ (specialize m% (length args) (loop for i from 0 below 20 collect i)
+ (let ((argvars (loop for i from 0 below m%
+ collect (gensym (format nil "ARG~D-" i)))))
+ `(let ,(loop for var in argvars
+ for i from 0 below m%
+ collect `(,var (nth ,i args*)))
+ (if (fboundp f)
+ (let ((f* (fdefinition f)))
+ (lambda (env)
+ (declare (ignorable env))
+ (funcall f*
+ ,@(loop for var in argvars
+ collect `(funcall (the eval-closure ,var) env)))))
+ (lambda (env)
+ (declare (ignorable env))
+ (funcall (fdefinition f)
+ ,@(loop for var in argvars
+ collect `(funcall (the eval-closure ,var) env))))))))
+ (if (fboundp f)
+ (let ((f* (fdefinition f)))
+ (lambda (env)
+ (apply f*
+ (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))
+ (lambda (env)
+ (apply (fdefinition f)
+ (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))))))
(declaim (ftype (function (eval-closure list context) eval-closure) prepare-direct-call))
(defun prepare-direct-call (f args context)